diff --git a/Help/hmt.help.lhs b/Help/hmt.help.lhs deleted file mode 100644 --- a/Help/hmt.help.lhs +++ /dev/null @@ -1,175 +0,0 @@ -# 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) diff --git a/Music/Theory/Array.hs b/Music/Theory/Array.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array.hs @@ -0,0 +1,90 @@ +module Music.Theory.Array where + +import Data.List {- base -} +import qualified Data.Array as A {- array -} + +import qualified Music.Theory.List as T {- hmt -} + +-- * Association List (List Array) + +larray_bounds :: Ord k => [(k,v)] -> (k,k) +larray_bounds = T.minmax . map fst + +larray :: A.Ix k => [(k,v)] -> A.Array k v +larray a = A.array (larray_bounds a) a + +-- * List Table + +-- | Append a sequence of /nil/ (or default) values to each row of /tbl/ +-- so to make it regular (ie. all rows of equal length). +make_regular :: t -> [[t]] -> [[t]] +make_regular k tbl = + let z = maximum (map length tbl) + in map (T.pad_right k z) tbl + +-- * Matrix Indices + +-- | Matrix dimensions are written (rows,columns). +type Dimensions i = (i,i) + +-- | Matrix indices are written (row,column) & are here _zero_ indexed. +type Ix i = (i,i) + +-- | Translate 'Ix' by row and column delta. +-- +-- > ix_translate (1,2) (3,4) == (4,6) +ix_translate :: Num t => (t,t) -> Ix t -> Ix t +ix_translate (dr,dc) (r,c) = (r + dr,c + dc) + +-- | Modulo 'Ix' by 'Dimensions'. +-- +-- > ix_modulo (4,4) (3,7) == (3,3) +ix_modulo :: Integral t => Dimensions t -> Ix t -> Ix t +ix_modulo (nr,nc) (r,c) = (r `mod` nr,c `mod` nc) + +-- | Given number of columns and row index, list row indices. +-- +-- > row_indices 3 1 == [(1,0),(1,1),(1,2)] +row_indices :: (Enum t, Num t) => t -> t -> [Ix t] +row_indices nc r = map (\c -> (r,c)) [0 .. nc - 1] + +-- | Given number of rows and column index, list column indices. +-- +-- > column_indices 3 1 == [(0,1),(1,1),(2,1)] +column_indices :: (Enum t, Num t) => t -> t -> [Ix t] +column_indices nr c = map (\r -> (r,c)) [0 .. nr - 1] + +-- | All zero-indexed matrix indices, in row order. This is the order +-- given by 'sort'. +-- +-- > matrix_indices (2,3) == [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2)] +-- > sort (matrix_indices (2,3)) == matrix_indices (2,3) +matrix_indices :: (Enum t, Num t) => Dimensions t -> [Ix t] +matrix_indices (nr,nc) = concatMap (row_indices nc) [0 .. nr - 1 ] + +-- | Corner indices of given 'Dimensions', in row order. +-- +-- > matrix_corner_indices (2,3) == [(0,0),(0,2),(1,0),(1,2)] +matrix_corner_indices :: Num t => Dimensions t -> [Ix t] +matrix_corner_indices (nr,nc) = [(0,0),(0,nc - 1),(nr - 1,0),(nr - 1,nc - 1)] + +-- | Parallelogram corner indices, given as rectangular 'Dimensions' with an +-- offset for the lower indices. +-- +-- > parallelogram_corner_indices ((2,3),2) == [(0,0),(0,2),(1,2),(1,4)] +parallelogram_corner_indices :: Num t => (Dimensions t,t) -> [Ix t] +parallelogram_corner_indices ((nr,nc),o) = [(0,0),(0,nc - 1),(nr - 1,o),(nr - 1,nc + o - 1)] + +-- | Apply 'ix_modulo' and 'ix_translate' for all 'matrix_indices', +-- ie. all translations of a 'shape' in row order. The resulting 'Ix' +-- sets are not sorted and may have duplicates. +-- +-- > concat (all_ix_translations (2,3) [(0,0)]) == matrix_indices (2,3) +all_ix_translations :: Integral t => Dimensions t -> [Ix t] -> [[Ix t]] +all_ix_translations dm ix = + let f z = ix_modulo dm . ix_translate z + in map (\dx -> map (f dx) ix) (matrix_indices dm) + +-- | Sort sets into row order and remove duplicates. +all_ix_translations_uniq :: Integral t => Dimensions t -> [Ix t] -> [[Ix t]] +all_ix_translations_uniq dm = nub . map sort . all_ix_translations dm diff --git a/Music/Theory/Array/CSV.hs b/Music/Theory/Array/CSV.hs --- a/Music/Theory/Array/CSV.hs +++ b/Music/Theory/Array/CSV.hs @@ -1,228 +1,25 @@ -- | 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 qualified Data.Array as A {- array -} import Data.List {- base -} -import Data.String {- base -} import qualified Text.CSV.Lazy.String as C {- lazy-csv -} +import qualified Music.Theory.Array.Cell_Ref as T {- hmt -} +import qualified Music.Theory.IO as T {- hmt -} 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)] +import qualified Music.Theory.Tuple as T {- hmt -} -- * TABLE -- | When reading a CSV file is the first row a header? type CSV_Has_Header = Bool +-- | Alias for 'Char', allow characters other than @,@ as delimiter. type CSV_Delimiter = Char +-- | Alias for 'Bool', allow linebreaks in fields. type CSV_Allow_Linebreaks = Bool -- | When writing a CSV file should the delimiters be aligned, @@ -242,26 +39,28 @@ -- columns. type Table a = [[a]] --- | CSV table, ie. a table with perhaps a header. +-- | CSV table, ie. a 'Table' with 'Maybe' a header. type CSV_Table a = (Maybe [String],Table a) --- | Read 'Table' from @CSV@ file. +-- | Read 'CSV_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 + s <- T.read_file_utf8 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 +csv_table_read_def :: (String -> a) -> FilePath -> IO (Table a) +csv_table_read_def f = fmap snd . csv_table_read def_csv_opt f --- | Read and process @CSV@ 'Table'. +-- | Read and process @CSV@ '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) +-- | Align table according to 'CSV_Align_Columns'. +-- -- > 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 = @@ -274,40 +73,43 @@ CSV_Align_Right -> s ++ pd in transpose (zipWith (map . ext) n c) --- | Write 'Table' to @CSV@ file. +-- | Pretty-print 'CSV_Table'. +csv_table_pp :: (a -> String) -> CSV_Opt -> CSV_Table a -> String +csv_table_pp f (_,delim,brk,align) (hdr,tbl) = + let tbl' = csv_table_align align (T.mcons hdr (map (map f) tbl)) + (_,t) = C.toCSVTable tbl' + in C.ppDSVTable brk delim t + +-- | 'T.write_file_utf8' of 'csv_table_pp'. 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 +csv_table_write f opt fn csv = T.write_file_utf8 fn (csv_table_pp f opt csv) --- | 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) +-- | Write 'Table' only (no header) with 'def_csv_opt'. +csv_table_write_def :: (a -> String) -> FilePath -> Table a -> IO () +csv_table_write_def f fn tbl = csv_table_write f def_csv_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 +table_row :: Table a -> T.Row_Ref -> [a] +table_row t r = t !! T.row_index r -- | Column data. -table_column :: Table a -> Column_Ref -> [a] -table_column t c = transpose t !! column_index c +table_column :: Table a -> T.Column_Ref -> [a] +table_column t c = transpose t !! 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 :: Eq a => Table a -> (T.Column_Ref,T.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 :: Table a -> T.Cell_Ref -> a table_cell t (c,r) = - let (r',c') = (row_index r,column_index c) + let (r',c') = (T.row_index r,T.column_index c) in table_lookup t (r',c') -- | @0@-indexed (row,column) cell lookup over column range. @@ -317,9 +119,9 @@ 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 :: Table a -> (T.Row_Ref,T.Column_Range) -> [a] table_row_segment t (r,c) = - let (r',c') = (row_index r,column_indices c) + let (r',c') = (T.row_index r,T.column_indices c) in table_lookup_row_segment t (r',c') -- * Array @@ -333,14 +135,55 @@ -- > > (((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 :: Table a -> A.Array T.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 + bnd = (T.cell_ref_minima,(toEnum (nc - 1),nr)) + asc = zip (T.cell_range_row_order bnd) (concat t) + in A.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 :: CSV_Opt -> (String -> a) -> FilePath -> IO (A.Array T.Cell_Ref a) csv_array_read opt f fn = fmap (table_to_array . snd) (csv_table_read opt f fn) + +-- * Irregular + +csv_field_str :: C.CSVField -> String +csv_field_str f = + case f of + C.CSVField _ _ _ _ s _ -> s + C.CSVFieldError _ _ _ _ _ -> error "csv_field_str" + +csv_error_recover :: C.CSVError -> C.CSVRow +csv_error_recover e = + case e of + C.IncorrectRow _ _ _ f -> f + C.BlankLine _ _ _ _ -> [] + _ -> error "csv_error_recover: not recoverable" + +csv_row_recover :: Either [C.CSVError] C.CSVRow -> C.CSVRow +csv_row_recover r = + case r of + Left [e] -> csv_error_recover e + Left _ -> error "csv_row_recover: multiple errors" + Right r' -> r' + +-- | Read irregular @CSV@ file, ie. rows may have any number of columns, including no columns. +csv_load_irregular :: (String -> a) -> FilePath -> IO [[a]] +csv_load_irregular f fn = do + s <- T.read_file_utf8 fn + return (map (map (f . csv_field_str) . csv_row_recover) (C.parseCSV s)) + +-- * Tuples + +type P5_Parser t1 t2 t3 t4 t5 = (String -> t1,String -> t2,String -> t3,String -> t4,String -> t5) +type P5_Writer t1 t2 t3 t4 t5 = (t1 -> String,t2 -> String,t3 -> String,t4 -> String,t5 -> String) + +csv_table_read_p5 :: P5_Parser t1 t2 t3 t4 t5 -> CSV_Opt -> FilePath -> IO (Maybe [String],[(t1,t2,t3,t4,t5)]) +csv_table_read_p5 f opt fn = do + (hdr,dat) <- csv_table_read opt id fn + return (hdr,map (T.p5_from_list f) dat) + +csv_table_write_p5 :: P5_Writer t1 t2 t3 t4 t5 -> CSV_Opt -> FilePath -> (Maybe [String],[(t1,t2,t3,t4,t5)]) -> IO () +csv_table_write_p5 f opt fn (hdr,dat) = csv_table_write id opt fn (hdr,map (T.p5_to_list f) dat) diff --git a/Music/Theory/Array/CSV/Midi.hs b/Music/Theory/Array/CSV/Midi.hs deleted file mode 100644 --- a/Music/Theory/Array/CSV/Midi.hs +++ /dev/null @@ -1,86 +0,0 @@ --- | 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' diff --git a/Music/Theory/Array/CSV/Midi/MND.hs b/Music/Theory/Array/CSV/Midi/MND.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/CSV/Midi/MND.hs @@ -0,0 +1,203 @@ +-- | Functions for reading midi note data (MND) from CSV files. +-- This is /not/ a generic text midi notation. +-- The defined commands are @on@ and @off@, but others may be present. +-- Non-integral note number and key velocity data are allowed. +module Music.Theory.Array.CSV.Midi.MND where + +import Data.List.Split {- split -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Word {- base -} + +import qualified Music.Theory.Array.CSV as T {- hmt -} +import qualified Music.Theory.Math as T {- hmt -} +import qualified Music.Theory.Read as T {- hmt -} +import qualified Music.Theory.Time.Seq as T {- hmt -} + +-- | If /r/ is whole to /k/ places then show as integer, else as float to /k/ places. +data_value_pp :: Real t => Int -> t -> String +data_value_pp k r = + if T.whole_to_precision k r + then show (T.real_floor_int r) + else T.real_pp k r + +-- | Channel values are 4-bit (0-15). +type Channel = Word8 + +-- | The required header field. +csv_mnd_hdr :: [String] +csv_mnd_hdr = ["time","on/off","note","velocity","channel","param"] + +type Param = (String,Double) + +param_parse :: String -> [Param] +param_parse str = + let f x = case splitOn "=" x of + [lhs,rhs] -> (lhs,read rhs) + _ -> error ("param_parse: " ++ x) + in if null str then [] else map f (splitOn ";" str) + +param_pp :: Int -> [Param] -> String +param_pp k = + let f (lhs,rhs) = concat [lhs,"=",T.real_pp k rhs] + in intercalate ";" . map f + +-- | Midi note data, the type parameters are to allow for fractional note & velocity values. +-- The command is a string, @on@ and @off@ are standard, other commands may be present. +-- +-- > unwords csv_mnd_hdr == "time on/off note velocity channel param" +type MND t n = (t,String,n,n,Channel,[Param]) + +csv_mnd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MND t n] +csv_mnd_parse (hdr,dat) = + let err x = error ("csv_mnd_read: " ++ x) + f m = case m of + [st,msg,mnn,vel,ch,pm] -> + (T.reads_exact_err "time:real" st + ,msg + ,T.reads_exact_err "note:real" mnn + ,T.reads_exact_err "velocity:real" vel + ,T.reads_exact_err "channel:int" ch + ,param_parse pm) + _ -> err "entry?" + in case hdr of + Just hdr' -> if hdr' == csv_mnd_hdr then map f dat else err "header?" + Nothing -> err "no header?" + +load_csv :: FilePath -> IO (T.CSV_Table String) +load_csv = T.csv_table_read (True,',',False,T.CSV_No_Align) id + +-- | Midi note data. +-- +-- > let fn = "/home/rohan/cvs/uc/uc-26/daily-practice/2014-08-13.1.csv" +-- > m <- csv_mnd_read fn :: IO [MND Double Double] +-- > length m == 17655 +-- > csv_mnd_write 4 "/tmp/t.csv" m +csv_mnd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MND t n] +csv_mnd_read = fmap csv_mnd_parse . load_csv + +-- | Writer. +csv_mnd_write :: (Real t,Real n) => Int -> FilePath -> [MND t n] -> IO () +csv_mnd_write r_prec nm = + let un_node (st,msg,mnn,vel,ch,pm) = + [T.real_pp r_prec st + ,msg + ,data_value_pp r_prec mnn + ,data_value_pp r_prec vel + ,show ch + ,param_pp r_prec pm] + with_hdr dat = (Just csv_mnd_hdr,dat) + in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node + +-- * MND Seq forms + +-- | (p0=midi-note,p1=velocity,channel,param) +type Event n = (n,n,Channel,[Param]) + +-- | Translate from 'Tseq' form to 'Wseq' form. +midi_tseq_to_midi_wseq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (Event n)) -> T.Wseq t (Event n) +midi_tseq_to_midi_wseq = T.tseq_begin_end_to_wseq (\(n0,_,c0,_) (n1,_,c1,_) -> c0 == c1 && n0 == n1) + +midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t x -> T.Tseq t (T.Begin_End x) +midi_wseq_to_midi_tseq = T.wseq_begin_end + +-- | Ignores non on/off messages. +mnd_to_tseq :: Num n => [MND t n] -> T.Tseq t (T.Begin_End (Event n)) +mnd_to_tseq = + let mk_node (st,msg,mnn,vel,ch,pm) = + case msg of + "on" -> Just (st,T.Begin (mnn,vel,ch,pm)) + "off" -> Just (st,T.End (mnn,0,ch,pm)) + _ -> Nothing + in mapMaybe mk_node + +-- | 'Tseq' form of 'csv_mnd_read', channel information is retained, off-velocity is zero. +csv_mnd_read_tseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.Begin_End (Event n))) +csv_mnd_read_tseq = fmap mnd_to_tseq . csv_mnd_read + +-- | 'Tseq' form of 'csv_mnd_write', data is . +csv_mnd_write_tseq :: (Real t,Real n) => Int -> FilePath -> T.Tseq t (T.Begin_End (Event n)) -> IO () +csv_mnd_write_tseq r_prec nm sq = + let f (t,e) = case e of + T.Begin (n,v,c,p) -> (t,"on",n,v,c,p) + T.End (n,_,c,p) -> (t,"off",n,0,c,p) + in csv_mnd_write r_prec nm (map f sq) + +-- * MNDD (simplifies cases where overlaps on the same channel are allowed). + +-- | Message should be @note@ for note data. +csv_mndd_hdr :: [String] +csv_mndd_hdr = ["time","duration","message","note","velocity","channel","param"] + +-- > unwords csv_mndd_hdr == "time duration message note velocity channel param" +type MNDD t n = (t,t,String,n,n,Channel,[Param]) + +csv_mndd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MNDD t n] +csv_mndd_parse (hdr,dat) = + let err x = error ("csv_mndd_read: " ++ x) + f m = + case m of + [st,du,msg,mnn,vel,ch,pm] -> + (T.reads_exact_err "time" st + ,T.reads_exact_err "duration" du + ,msg + ,T.reads_exact_err "note" mnn + ,T.reads_exact_err "velocity" vel + ,T.reads_exact_err "channel" ch + ,param_parse pm) + _ -> err "entry?" + in case hdr of + Just hdr' -> if hdr' == csv_mndd_hdr then map f dat else err "header?" + Nothing -> err "no header?" + +-- | Midi note/duration data. +csv_mndd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MNDD t n] +csv_mndd_read = fmap csv_mndd_parse . load_csv + +-- | Writer. +csv_mndd_write :: (Real t,Real n) => Int -> FilePath -> [MNDD t n] -> IO () +csv_mndd_write r_prec nm = + let un_node (st,du,msg,mnn,vel,ch,pm) = + [T.real_pp r_prec st,T.real_pp r_prec du,msg + ,data_value_pp r_prec mnn,data_value_pp r_prec vel + ,show ch + ,param_pp r_prec pm] + with_hdr dat = (Just csv_mndd_hdr,dat) + in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node + +-- * MNDD Seq forms + +-- | Ignores non note messages. +mndd_to_wseq :: [MNDD t n] -> T.Wseq t (Event n) +mndd_to_wseq = + let mk_node (st,du,msg,mnn,vel,ch,pm) = + case msg of + "note" -> Just ((st,du),(mnn,vel,ch,pm)) + _ -> Nothing + in mapMaybe mk_node + +-- | 'Wseq' form of 'csv_mndd_read'. +csv_mndd_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n)) +csv_mndd_read_wseq = fmap mndd_to_wseq . csv_mndd_read + +-- | 'Wseq' form of 'csv_mndd_write'. +csv_mndd_write_wseq :: (Real t,Real n) => Int -> FilePath -> T.Wseq t (Event n) -> IO () +csv_mndd_write_wseq r_prec nm = + let f ((st,du),(mnn,vel,ch,pm)) = (st,du,"note",mnn,vel,ch,pm) + in csv_mndd_write r_prec nm . map f + +-- * Composite + +-- | Parse either MND or MNDD data to Wseq, CSV type is decided by header. +csv_midi_parse_wseq :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> T.Wseq t (Event n) +csv_midi_parse_wseq (hdr,dat) = do + case hdr of + Just hdr' -> if hdr' == csv_mnd_hdr + then midi_tseq_to_midi_wseq (mnd_to_tseq (csv_mnd_parse (hdr,dat))) + else if hdr' == csv_mndd_hdr + then mndd_to_wseq (csv_mndd_parse (hdr,dat)) + else error "csv_midi_read_wseq: not MND or MNDD" + _ -> error "csv_midi_read_wseq: header?" + +csv_midi_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n)) +csv_midi_read_wseq = fmap csv_midi_parse_wseq . load_csv diff --git a/Music/Theory/Array/Cell_Ref.hs b/Music/Theory/Array/Cell_Ref.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Cell_Ref.hs @@ -0,0 +1,228 @@ +-- | Cell references & indexing. +module Music.Theory.Array.Cell_Ref where + +import qualified Data.Array as A {- array -} +import Data.Char {- base -} +import Data.Function {- base -} +import Data.Maybe {- base -} +import Data.String {- base -} + +-- | @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 A.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 = A.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 + +is_cell_ref :: String -> Bool +is_cell_ref = isJust . parse_cell_ref + +parse_cell_ref_err :: String -> Cell_Ref +parse_cell_ref_err = fromMaybe (error "parse_cell_ref") . parse_cell_ref + +-- | 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) + +-- | Inverse of cell_index. +-- +-- > index_to_cell (80,347) == (Column_Ref "CC",348) +-- > index_to_cell (4,5) == (Column_Ref "E",6) +index_to_cell :: (Int,Int) -> Cell_Ref +index_to_cell (c,r) = (column_ref c,r + 1) + +parse_cell_index :: String -> (Int,Int) +parse_cell_index = cell_index . parse_cell_ref_err + +-- | 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)] + diff --git a/Music/Theory/Array/Direction.hs b/Music/Theory/Array/Direction.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Direction.hs @@ -0,0 +1,84 @@ +-- | Directions in an array. +module Music.Theory.Array.Direction where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Array.Cell_Ref as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} + +-- * LOC / VEC + +-- | (column,row) +type LOC n = (n,n) + +-- | (Δcolumn,Δrow), rows /descend/, ie. down is positive, up is negative. +type VEC n = (n,n) + +vector_add :: Num n => VEC n -> VEC n -> VEC n +vector_add (c1,r1) (c2,r2) = (c1 + c2,r1 + r2) + +vector_sub :: Num n => VEC n -> VEC n -> VEC n +vector_sub (c1,r1) (c2,r2) = (c1 - c2,r1 - r2) + +vector_sum :: Num n => [VEC n] -> VEC n +vector_sum = foldl1 vector_add + +apply_vec :: Num n => LOC n -> VEC n -> LOC n +apply_vec (c,r) (dc,dr) = (c + dc,r + dr) + +-- | Segment 'VEC' into a sequence of unit steps. +-- +-- > let r = [[(0,0)],[(0,1)],[(0,1),(-1,0)],[(0,1),(0,1),(0,1),(-1,0),(-1,0)]] +-- > in map segment_vec [(0,0),(0,1),(-1,1),(-2,3)] == r +segment_vec :: Integral n => VEC n -> [VEC n] +segment_vec v = + case v of + (0,0) -> [v] + (c,r) -> genericReplicate (abs r) (0,signum r) ++ genericReplicate (abs c) (signum c,0) + +derive_vec :: Num n => LOC n -> LOC n -> VEC n +derive_vec (c1,r1) (c2,r2) = (c2 - c1,r2 - r1) + +unfold_path :: Num n => LOC n -> [VEC n] -> [LOC n] +unfold_path l p = scanl apply_vec l p + +-- * DIRECTION (non-diagonal) + +type DIRECTION_S = String + +-- | Directions are D=down, L=left, R=right, U=up. +is_direction :: String -> Bool +is_direction = (`elem` "DLRU.") . head + +type DIRECTION_C = Char + +-- | Reads either S|D W|L E|R N|U, reverse lookup gives SWEN. A period +-- indicates (0,0). S=south, W=west, E=east, N=north. +direction_char_to_vector_tbl :: Num n => [(DIRECTION_C,VEC n)] +direction_char_to_vector_tbl = + [('.',(0,0)) + ,('S',(0,1)),('W',(-1,0)),('E',(1,0)),('N',(0,-1)) + ,('D',(0,1)),('L',(-1,0)),('R',(1,0)),('U',(0,-1))] + +-- > map direction_char_to_vector "LU" +direction_char_to_vector :: Num n => DIRECTION_C -> VEC n +direction_char_to_vector d = fromMaybe (error "dir?") $ lookup d direction_char_to_vector_tbl + +-- > let r = [(0,-1),(0,1),(-1,0),(1,0),(-1,-1),(1,1),(-2,0),(-1,-1)] +-- > in map direction_to_vector (words "U D L R UL DR LL LU") == r +direction_to_vector :: Num n => [DIRECTION_C] -> VEC n +direction_to_vector = vector_sum . map direction_char_to_vector + +vector_to_direction_char :: (Eq n, Num n) => VEC n -> DIRECTION_C +vector_to_direction_char v = + let r = T.reverse_lookup v direction_char_to_vector_tbl + in fromMaybe (error "vec->dir?") r + +-- | Direction sequence to cell references. +dir_seq_to_cell_seq :: (String,[String]) -> [String] +dir_seq_to_cell_seq (l,v) = + let p = map direction_to_vector v + c = T.parse_cell_index l + in map (T.cell_ref_pp . T.index_to_cell) (unfold_path c p) + diff --git a/Music/Theory/Array/MD.hs b/Music/Theory/Array/MD.hs --- a/Music/Theory/Array/MD.hs +++ b/Music/Theory/Array/MD.hs @@ -1,25 +1,11 @@ -- | 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.Array as T {- hmt -} 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 +import qualified Music.Theory.String as T {- hmt -} -- | Optional header row then data rows. type MD_Table t = (Maybe [String],[[t]]) @@ -39,19 +25,21 @@ in (hdr',tbl') -- | Markdown table, perhaps with header. Table is in row order. --- Options are: /pad_left/. +-- Options are /pad_left/ and /eq_width/. -- --- > 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 +-- > let tbl = [["a","bc","def"],["ghij","klm","no","p"]] +-- > putStrLn$unlines$"": md_table_opt (True,True," · ") (Nothing,tbl) +md_table_opt :: (Bool,Bool,String) -> MD_Table String -> [String] +md_table_opt (pad_left,eq_width,col_sep) (hdr,t) = + let c = transpose (T.make_regular "" (maybe t (:t) hdr)) + nc = length c + n = let k = map (maximum . map length) c + in if eq_width then replicate nc (maximum k) else k + ext k s = if pad_left then T.pad_left ' ' k s else T.pad_right ' ' k s + jn = intercalate col_sep + m = jn (map (flip replicate '-') n) + w = map jn (transpose (zipWith (map . ext) n c)) + d = map T.delete_trailing_whitespace w in case hdr of Nothing -> T.bracket (m,m) d Just _ -> case d of @@ -59,7 +47,7 @@ d0:d' -> d0 : T.bracket (m,m) d' md_table' :: MD_Table String -> [String] -md_table' = md_table_opt True +md_table' = md_table_opt (True,False," ") -- | 'curry' of 'md_table''. md_table :: Maybe [String] -> [[String]] -> [String] @@ -88,24 +76,33 @@ {- | 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]]) +> let h = (map return "abc",map return "efgh") +> let t = md_matrix "" h (map (map show) [[1,2,3,4],[2,3,4,1],[3,4,1,2]]) >>> putStrLn $ unlines $ md_table' t -- - - - - a b c -a 1 2 3 -b 2 3 1 -c 3 1 2 -- - - - +- - - - - + e f g h +a 1 2 3 4 +b 2 3 4 1 +c 3 4 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) +md_matrix :: a -> ([a],[a]) -> [[a]] -> MD_Table a +md_matrix nil (r,c) t = md_table_join (Nothing,[nil] : map return r) (Nothing,c : t) --- | Variant for 'String' tables where /nil/ is the empty string and +-- | Variant that takes a 'show' function and a /header decoration/ function. +md_matrix_opt :: (a -> String) -> (String -> String) -> ([a],[a]) -> [[a]] -> MD_Table String +md_matrix_opt show_f hd_f nm t = + let t' = map (map show_f) t + nm' = T.bimap1 (map (hd_f . show_f)) nm + in md_matrix "" nm' t' + +-- | MD embolden function. +md_embolden :: String -> String +md_embolden x = "__" ++ x ++ "__" + +-- | 'md_matrix_opt' with 'show' and markdown /bold/ annotations for header. -- 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 +md_matrix_bold :: Show a => ([a],[a]) -> [[a]] -> MD_Table String +md_matrix_bold = md_matrix_opt show md_embolden diff --git a/Music/Theory/Bits.hs b/Music/Theory/Bits.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Bits.hs @@ -0,0 +1,38 @@ +-- | Bits functions. +module Music.Theory.Bits where + +import Data.Bits {- base -} + +bit_pp :: Bool -> Char +bit_pp b = if b then '1' else '0' + +bits_pp :: [Bool] -> String +bits_pp = map bit_pp + +-- | Generate /n/ place bit sequence for /x/. +gen_bitseq :: FiniteBits b => Int -> b -> [Bool] +gen_bitseq n x = + if finiteBitSize x < n + then error "gen_bitseq" + else map (testBit x) (reverse [0 .. n - 1]) + +-- | Given bit sequence (most to least significant) generate 'Bits' value. +-- +-- > :set -XBinaryLiterals +-- > pack_bitseq [True,False,True,False] == 0b1010 +-- > pack_bitseq [True,False,False,True,False,False] == 0b100100 +-- > 0b100100 == 36 +pack_bitseq :: Bits i => [Bool] -> i +pack_bitseq = + last . + scanl (\n (k,b) -> if b then setBit n k else n) zeroBits . + zip [0..] . + reverse + +-- | 'bits_pp' of 'gen_bitseq'. +-- +-- > :set -XBinaryLiterals +-- > 0xF0 == 0b11110000 +-- > gen_bitseq_pp 8 (0xF0::Int) == "11110000" +gen_bitseq_pp :: FiniteBits b => Int -> b -> String +gen_bitseq_pp n = bits_pp . gen_bitseq n diff --git a/Music/Theory/Bjorklund.hs b/Music/Theory/Bjorklund.hs --- a/Music/Theory/Bjorklund.hs +++ b/Music/Theory/Bjorklund.hs @@ -3,10 +3,12 @@ -- /Journal of Computational Geometry: Theory and Applications/ -- Volume 42, Issue 5, July, 2009 -- () -module Music.Theory.Bjorklund (bjorklund,xdot,iseq,iseq_str) where +module Music.Theory.Bjorklund where import Data.List.Split {- split -} +import qualified Music.Theory.List as T + type STEP a = ((Int,Int),([[a]],[[a]])) left :: STEP a -> STEP a @@ -26,63 +28,58 @@ 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'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] +> map xdot (bjorklund (5,9)) == "x.x.x.x.x" + +> let {es = [(2,[3,5]),(3,[4,5,8]),(4,[7,9,12,15]),(5,[6,7,8,9,11,12,13,16]) +> ,(6,[7,13]),(7,[8,9,10,12,15,16,17,18]),(8,[17,19]) +> ,(9,[14,16,22,23]),(11,[12,24]),(13,[24]),(15,[34])] +> ;es' = concatMap (\(i,j) -> map ((,) i) j) es} +> in mapM_ (putStrLn . euler_pp') es' + +> > E(2,3) [××·] (12) +> > E(2,5) [×·×··] (23) +> > E(3,4) [×××·] (112) +> > E(3,5) [×·×·×] (221) +> > E(3,8) [×··×··×·] (332) +> > E(4,7) [×·×·×·×] (2221) +> > E(4,9) [×·×·×·×··] (2223) +> > E(4,12) [×··×··×··×··] (3333) +> > E(4,15) [×···×···×···×··] (4443) +> > E(5,6) [×××××·] (11112) +> > E(5,7) [×·××·××] (21211) +> > E(5,8) [×·××·××·] (21212) +> > E(5,9) [×·×·×·×·×] (22221) +> > E(5,11) [×·×·×·×·×··] (22223) +> > E(5,12) [×··×·×··×·×·] (32322) +> > E(5,13) [×··×·×··×·×··] (32323) +> > E(5,16) [×··×··×··×··×···] (33334) +> > E(6,7) [××××××·] (111112) +> > E(6,13) [×·×·×·×·×·×··] (222223) +> > E(7,8) [×××××××·] (1111112) +> > E(7,9) [×·×××·×××] (2112111) +> > E(7,10) [×·××·××·××] (2121211) +> > E(7,12) [×·××·×·××·×·] (2122122) +> > E(7,15) [×·×·×·×·×·×·×··] (2222223) +> > E(7,16) [×··×·×·×··×·×·×·] (3223222) +> > E(7,17) [×··×·×··×·×··×·×·] (3232322) +> > E(7,18) [×··×·×··×·×··×·×··] (3232323) +> > E(8,17) [×·×·×·×·×·×·×·×··] (22222223) +> > E(8,19) [×··×·×·×··×·×·×··×·] (32232232) +> > E(9,14) [×·××·××·××·××·] (212121212) +> > E(9,16) [×·××·×·×·××·×·×·] (212221222) +> > E(9,22) [×··×·×··×·×··×·×··×·×·] (323232322) +> > E(9,23) [×··×·×··×·×··×·×··×·×··] (323232323) +> > E(11,12) [×××××××××××·] (11111111112) +> > E(11,24) [×··×·×·×·×·×··×·×·×·×·×·] (32222322222) +> > E(13,24) [×·××·×·×·×·×·××·×·×·×·×·] (2122222122222) +> > E(15,34) [×··×·×·×·×··×·×·×·×··×·×·×·×··×·×·] (322232223222322) + +-} bjorklund :: (Int,Int) -> [Bool] bjorklund (i,j') = let j = j' - i @@ -91,11 +88,42 @@ (_,(x',y')) = bjorklund' ((i,j),(x,y)) in concat x' ++ concat y' +-- | 'T.rotate_right' of 'bjorklund'. +-- +-- > map xdot' (bjorklund_r 2 (5,16)) == "··×··×··×··×··×·" +bjorklund_r :: Int -> (Int, Int) -> [Bool] +bjorklund_r n = T.rotate_right n . bjorklund + +-- | Pretty printer, generalise. +euler_pp_f :: (Bool -> Char) -> (Int,Int) -> String +euler_pp_f f e = + let r = bjorklund e + in concat ["E",show e," [",map f r,"] ",iseq_str r] + +-- | Unicode form, ie. @×·@. +-- +-- > euler_pp' (7,12) == "E(7,12) [×·××·×·××·×·] (2122122)" +euler_pp' :: (Int, Int) -> String +euler_pp' = euler_pp_f xdot' + +-- | ASCII form, ie. @x.@. +-- +-- > euler_pp (7,12) == "E(7,12) [x.xx.x.xx.x.] (2122122)" +euler_pp :: (Int, Int) -> String +euler_pp = euler_pp_f xdot + -- | /xdot/ notation for pattern. -- --- > xdot (bjorklund (5,9)) == "x.x.x.x.x" -xdot :: [Bool] -> String -xdot = map (\x -> if x then 'x' else '.') +-- > map xdot (bjorklund (5,9)) == "x.x.x.x.x" +xdot :: Bool -> Char +xdot x = if x then 'x' else '.' + +-- | Unicode variant. +-- +-- > map xdot' (bjorklund (5,12)) == "×··×·×··×·×·" +-- > map xdot' (bjorklund (5,16)) == "×··×··×··×··×···" +xdot' :: Bool -> Char +xdot' x = if x then '×' else '·' -- | The 'iseq' of a pattern is the distance between 'True' values. -- diff --git a/Music/Theory/Block_Design/Johnson_2007.hs b/Music/Theory/Block_Design/Johnson_2007.hs --- a/Music/Theory/Block_Design/Johnson_2007.hs +++ b/Music/Theory/Block_Design/Johnson_2007.hs @@ -2,7 +2,7 @@ -- Computation in Music, Berlin, May 2007. module Music.Theory.Block_Design.Johnson_2007 where -import Control.Arrow {- base -} +import Control.Arrow ((***)) {- base -} import Data.List {- base -} import qualified Music.Theory.List as T diff --git a/Music/Theory/Braille.hs b/Music/Theory/Braille.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Braille.hs @@ -0,0 +1,273 @@ +-- | +module Music.Theory.Braille where + +import Data.Char {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Text.Printf {- base -} + +-- | Braille coding data. Elements are: (ASCII HEX,ASCII CHAR,DOT +-- LIST,UNICODE CHAR,MEANING). The dot numbers are in column order. +type BRAILLE = (Int,Char,[Int],Char,String) + +-- | ASCII 'Char' of 'BRAILLE'. +braille_ascii :: BRAILLE -> Char +braille_ascii (_,c,_,_,_) = c + +-- | Unicode 'Char' of 'BRAILLE'. +braille_unicode :: BRAILLE -> Char +braille_unicode (_,_,_,c,_) = c + +-- | Dot list of 'BRAILLE'. +braille_dots :: BRAILLE -> [Int] +braille_dots (_,_,d,_,_) = d + +-- | ASCII Braille table. +-- +-- > all id (map (\(x,c,_,_,_) -> x == fromEnum c) braille_table) == True +braille_table :: [BRAILLE] +braille_table = + [(0x20,' ',[],'⠀'," ") + ,(0x21,'!',[2,3,4,6],'⠮',"the") + ,(0x22,'"',[5],'⠐',"contraction") + ,(0x23,'#',[3,4,5,6],'⠼',"number prefix") + ,(0x24,'$',[1,2,4,6],'⠫',"ed") + ,(0x25,'%',[1,4,6],'⠩',"sh") + ,(0x26,'&',[1,2,3,4,6],'⠯',"and") + ,(0x27,'\'',[3],'⠄',"'") + ,(0x28,'(',[1,2,3,5,6],'⠷',"of") + ,(0x29,')',[2,3,4,5,6],'⠾',"with") + ,(0x2A,'*',[1,6],'⠡',"ch") + ,(0x2B,'+',[3,4,6],'⠬',"ing") + ,(0x2C,',',[6],'⠠',"uppercase prefix") + ,(0x2D,'-',[3,6],'⠤',"-") + ,(0x2E,'.',[4,6],'⠨',"italic prefix") + ,(0x2F,'/',[3,4],'⠌',"st") + ,(0x30,'0',[3,5,6],'⠴',"”") + ,(0x31,'1',[2],'⠂',",") + ,(0x32,'2',[2,3],'⠆',";") + ,(0x33,'3',[2,5],'⠒',":") + ,(0x34,'4',[2,5,6],'⠲',".") + ,(0x35,'5',[2,6],'⠢',"en") + ,(0x36,'6',[2,3,5],'⠖',"!") + ,(0x37,'7',[2,3,5,6],'⠶',"( or )") + ,(0x38,'8',[2,3,6],'⠦',"“ or ?") + ,(0x39,'9',[3,5],'⠔',"in") + ,(0x3A,':',[1,5,6],'⠱',"wh") + ,(0x3B,';',[5,6],'⠰',"letter prefix") + ,(0x3C,'<',[1,2,6],'⠣',"gh") + ,(0x3D,'=',[1,2,3,4,5,6],'⠿',"for") + ,(0x3E,'>',[3,4,5],'⠜',"ar") + ,(0x3F,'?',[1,4,5,6],'⠹',"th") + ,(0x40,'@',[4],'⠈',"accent prefix") + ,(0x41,'A',[1],'⠁',"a") + ,(0x42,'B',[1,2],'⠃',"b") + ,(0x43,'C',[1,4],'⠉',"c") + ,(0x44,'D',[1,4,5],'⠙',"d") + ,(0x45,'E',[1,5],'⠑',"e") + ,(0x46,'F',[1,2,4],'⠋',"f") + ,(0x47,'G',[1,2,4,5],'⠛',"g") + ,(0x48,'H',[1,2,5],'⠓',"h") + ,(0x49,'I',[2,4],'⠊',"i") + ,(0x4A,'J',[2,4,5],'⠚',"j") + ,(0x4B,'K',[1,3],'⠅',"k") + ,(0x4C,'L',[1,2,3],'⠇',"l") + ,(0x4D,'M',[1,3,4],'⠍',"m") + ,(0x4E,'N',[1,3,4,5],'⠝',"n") + ,(0x4F,'O',[1,3,5],'⠕',"o") + ,(0x50,'P',[1,2,3,4],'⠏',"p") + ,(0x51,'Q',[1,2,3,4,5],'⠟',"q") + ,(0x52,'R',[1,2,3,5],'⠗',"r") + ,(0x53,'S',[2,3,4],'⠎',"s") + ,(0x54,'T',[2,3,4,5],'⠞',"t") + ,(0x55,'U',[1,3,6],'⠥',"u") + ,(0x56,'V',[1,2,3,6],'⠧',"v") + ,(0x57,'W',[2,4,5,6],'⠺',"w") + ,(0x58,'X',[1,3,4,6],'⠭',"x") + ,(0x59,'Y',[1,3,4,5,6],'⠽',"y") + ,(0x5A,'Z',[1,3,5,6],'⠵',"z") + ,(0x5B,'[',[2,4,6],'⠪',"ow") + ,(0x5C,'\\',[1,2,5,6],'⠳',"ou") + ,(0x5D,']',[1,2,4,5,6],'⠻',"er") + ,(0x5E,'^',[4,5],'⠘',"currency prefix") + ,(0x5F,'_',[4,5,6],'⠸',"contraction") + ] + +-- | Lookup 'BRAILLE' value for unicode character. +-- +-- > braille_lookup_unicode '⠝' == Just (0x4E,'N',[1,3,4,5],'⠝',"n") +braille_lookup_unicode :: Char -> Maybe BRAILLE +braille_lookup_unicode c = find ((== c) . braille_unicode) braille_table + +-- | Lookup 'BRAILLE' value for ascii character (case invariant). +-- +-- > braille_lookup_ascii 'N' == Just (0x4E,'N',[1,3,4,5],'⠝',"n") +braille_lookup_ascii :: Char -> Maybe BRAILLE +braille_lookup_ascii c = find ((== (toUpper c)) . braille_ascii) braille_table + +-- | The arrangement of the 6-dot patterns into /decades/, sequences +-- of (1,10,3) cells. The cell to the left of the decade is the empty +-- cell, the two cells to the right are the first two cells of the +-- decade shifted right. +-- +-- For each decade there are two extra cells that shift +-- the first two cells of the decade right one place. Subsequent +-- decades are derived by simple transformation of the first. The +-- second is the first with the addition of dot @3@, the third adds +-- dots @3@ and @6@, the fourth adds dot @6@ and the fifth shifts the +-- first down one row. +-- +-- The first decade has the 13 of the 16 4-dot patterns, the remaining +-- 3 are in the fifth decade, that is they are the three 4-dot +-- patterns that are down shifts of a 4-dot pattern. +-- +-- > let trimap f (p,q,r) = (f p,f q,f r) +-- > let f = map (fromJust . decode) in map (trimap f) braille_64 +braille_64 :: [(String,String,String)] +braille_64 = + [("⠀","⠁⠃⠉⠙⠑⠋⠛⠓⠊⠚","⠈⠘") + ,("⠄","⠅⠇⠍⠝⠕⠏⠟⠗⠎⠞","⠌⠜") + ,("⠤","⠥⠧⠭⠽⠵⠯⠿⠷⠮⠾","⠬⠼") + ,("⠠","⠡⠣⠩⠹⠱⠫⠻⠳⠪⠺","⠨⠸") + ,("","⠂⠆⠒⠲⠢⠖⠶⠦⠔⠴","⠐⠰")] + +-- | Transcribe ASCII to unicode braille. +-- +-- > transcribe_unicode "BRAILLE ASCII CHAR GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠁⠎⠉⠊⠊⠀⠉⠓⠁⠗⠀⠛⠗⠊⠙" +-- > transcribe_unicode "BRAILLE HTML TABLE GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠓⠞⠍⠇⠀⠞⠁⠃⠇⠑⠀⠛⠗⠊⠙" +transcribe_unicode :: String -> String +transcribe_unicode = map (braille_unicode . fromJust . braille_lookup_ascii) + +-- | Generate a character grid using inidicated values for filled and empty cells. +-- +-- > let ch = (' ','.') +-- > putStrLn$ transcribe_char_grid ch "BRAILLE ASCII CHAR GRID" +-- +-- > let ch = (white_circle,black_circle) +-- > putStrLn$ string_html_table $ transcribe_char_grid ch "BRAILLE HTML TABLE GRID" +transcribe_char_grid :: (Char,Char) -> String -> String +transcribe_char_grid (w,b) = + unlines . + map concat . + transpose . + map (dots_grid (w,b) . braille_dots . fromJust . braille_lookup_ascii) + +-- | Generate 6-dot grid given (white,black) values. +-- +-- > dots_grid (0,1) [1,2,3,5] == [[1,0],[1,1],[1,0]] +dots_grid :: (c,c) -> [Int] -> [[c]] +dots_grid (w,b) d = + let f n = if n `elem` d then b else w + in map (map f) [[1,4],[2,5],[3,6]] + +string_html_table :: String -> String +string_html_table s = + let f x = "" ++ [x] ++ "" + g x = "" ++ concatMap f x ++ "" + h x = "" ++ concatMap g x ++ "
" + in h (lines s) + +{- | Decoding. + +> let t0 = ["⠠⠁⠇⠇⠀⠓⠥⠍⠁⠝⠀⠆⠬⠎⠀⠜⠑⠀⠃⠕⠗⠝⠀⠋⠗⠑⠑⠀⠯⠀⠑⠟⠥⠁⠇⠀⠔⠀⠙⠊⠛⠝⠰⠽⠀⠯⠀⠐⠗⠎⠲" +> ,"⠠⠮⠽⠀⠜⠑⠀⠢⠙⠪⠫⠀⠾⠀⠗⠂⠎⠕⠝⠀⠯⠀⠒⠎⠉⠊⠰⠑⠀⠯⠀⠩⠙⠀⠁⠉⠞⠀⠞⠪⠜⠙⠎⠀⠐⠕⠀⠁⠝⠕⠤" +> ,"⠮⠗⠀⠔⠀⠁⠀⠸⠎⠀⠷⠀⠃⠗⠕⠮⠗⠓⠕⠕⠙⠲"] + +> concatMap (fromMaybe "#" . decode) (concat t0) + +-} +decode :: Char -> Maybe String +decode c = + case braille_lookup_unicode c of + Just (_,_,_,_,s) -> Just s + Nothing -> Nothing + +-- | Start and end unicode indices. +braille_rng :: Integral i => (i,i) +braille_rng = (0x2800,0x28FF) + +-- | All characters, in sequence. +-- +-- > length braille_seq == 256 +-- > putStrLn braille_seq +braille_seq :: [Char] +braille_seq = let (l,r) = braille_rng in [toEnum l .. toEnum r] + +-- | The /n/th character, zero indexed. +braille_char :: Int -> Char +braille_char = toEnum . (+) 0x2800 + +-- | Two element index, 255 * 255 = 65025 places. +-- +-- > map braille_ix [100,300] +braille_ix :: Int -> (Char,Char) +braille_ix n = + let (i,j) = n `divMod` 255 + f k = braille_char (k + 1) + in (f i,f j) + +-- | HTML character encoding (as hex integer). +-- +-- > unwords $ map unicode_html braille_seq +unicode_html :: Char -> String +unicode_html = printf "&#x%x;" . fromEnum + +-- * Unicode + +-- | White (empty) circle. +white_circle :: Char +white_circle = '○' + +-- | Black (filled) circle. +black_circle :: Char +black_circle = '●' + +-- | Shaded (hatched) circle. +shaded_circle :: Char +shaded_circle = '◍' + +-- * Contractions + +-- | Table of one letter contractions. +one_letter_contractions :: [(Char,String)] +one_letter_contractions = + [('⠃',"but") + ,('⠉',"can") + ,('⠙',"do") + ,('⠑',"every") + ,('⠋',"from,-self") + ,('⠛',"go") + ,('⠓',"have") + ,('⠚',"just") + ,('⠅',"knowledge") + ,('⠇',"like") + ,('⠍',"more") + ,('⠝',"not") + ,('⠏',"people") + ,('⠟',"quite") + ,('⠗',"rather") + ,('⠎',"so") + ,('⠞',"that") + ,('⠌',"still") + ,('⠥',"us") + ,('⠧',"very") + ,('⠭',"it") + ,('⠽',"you") + ,('⠵',"as") + ,('⠡',"child") + ,('⠩',"shall") + ,('⠹',"this") + ,('⠱',"which") + ,('⠳',"out") + ,('⠺',"will") + ,('⠆',"be,be-") + ,('⠒',"con-") + ,('⠲',"dis-") + ,('⠢',"enough") + ,('⠖',"to") + ,('⠶',"were") + ,('⠦',"his") + ,('⠔',"in") + ,('⠴',"by,was") + ,('⠤',"com-") + ] diff --git a/Music/Theory/Byte.hs b/Music/Theory/Byte.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Byte.hs @@ -0,0 +1,55 @@ +-- | Byte functions. +module Music.Theory.Byte where + +import qualified Data.ByteString as B {- bytestring -} +import Data.Char {- base -} +import Data.List.Split {- split -} +import Data.Maybe {- base -} +import Numeric {- base -} + +import qualified Music.Theory.Read as T {- hmt -} + +-- | Given /n/ in (0,255) make two character hex string. +-- +-- > mapMaybe byte_hex_pp [0x0F,0xF0,0xF0F] == ["0F","F0"] +byte_hex_pp :: (Integral i, Show i) => i -> Maybe String +byte_hex_pp n = + case showHex n "" of + [c] -> Just ['0',toUpper c] + [c,d] -> Just (map toUpper [c,d]) + _ -> Nothing + +-- | Erroring variant. +byte_hex_pp_err :: (Integral i, Show i) => i -> String +byte_hex_pp_err = fromMaybe (error "byte_hex_pp") . byte_hex_pp + +-- | 'unwords' of 'map' of 'byte_hex_pp_err'. +-- +-- > byte_seq_hex_pp [0x0F,0xF0] == "0F F0" +byte_seq_hex_pp :: (Integral i, Show i) => [i] -> String +byte_seq_hex_pp = unwords . map byte_hex_pp_err + +-- | Read two character hexadecimal string. +read_hex_byte :: (Eq t,Num t) => String -> t +read_hex_byte s = + case s of + [_,_] -> T.reads_to_read_precise_err "readHex" readHex s + _ -> error "read_hex_byte" + +read_hex_byte_seq :: (Eq t,Num t) => String -> [t] +read_hex_byte_seq = map read_hex_byte . words + +-- | Load binary 'U8' sequence from file. +load_byte_seq :: Integral i => FilePath -> IO [i] +load_byte_seq = fmap (map fromIntegral . B.unpack) . B.readFile + +store_byte_seq :: Integral i => FilePath -> [i] -> IO () +store_byte_seq fn = B.writeFile fn . B.pack . map fromIntegral + +-- | Load hexadecimal text 'U8' sequence from file. +load_hex_byte_seq :: Integral i => FilePath -> IO [i] +load_hex_byte_seq = fmap (map read_hex_byte . words) . readFile + +-- | Store 'U8' sequence as hexadecimal text, 16 words per line. +store_hex_byte_seq :: (Integral i,Show i) => FilePath -> [i] -> IO () +store_hex_byte_seq fn = writeFile fn . unlines . map unwords . chunksOf 16 . map byte_hex_pp_err diff --git a/Music/Theory/Clef.hs b/Music/Theory/Clef.hs --- a/Music/Theory/Clef.hs +++ b/Music/Theory/Clef.hs @@ -1,8 +1,8 @@ -- | Common music notation clefs. module Music.Theory.Clef where -import Music.Theory.Pitch -import Music.Theory.Pitch.Name +import Music.Theory.Pitch {- hmt -} +import Music.Theory.Pitch.Name {- hmt -} -- | Clef enumeration type. data Clef_T = Bass | Tenor | Alto | Treble | Percussion diff --git a/Music/Theory/Combinations.hs b/Music/Theory/Combinations.hs --- a/Music/Theory/Combinations.hs +++ b/Music/Theory/Combinations.hs @@ -1,19 +1,19 @@ -- | Combination functions. module Music.Theory.Combinations where -import Music.Theory.Permutations +import qualified Music.Theory.Permutations as T -- | 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 +nk_combinations n k = T.nk_permutations n k `div` T.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 :: Int -> [a] -> [[a]] combinations k s = case (k,s) of (0,_) -> [[]] diff --git a/Music/Theory/Contour/Polansky_1992.hs b/Music/Theory/Contour/Polansky_1992.hs --- a/Music/Theory/Contour/Polansky_1992.hs +++ b/Music/Theory/Contour/Polansky_1992.hs @@ -10,33 +10,13 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import qualified Music.Theory.Set.List as T +import qualified Music.Theory.List as T +import qualified Music.Theory.Ord 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)) +import qualified Music.Theory.Set.List as T -- * 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)] @@ -51,36 +31,6 @@ 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. @@ -109,7 +59,7 @@ data Contour_Half_Matrix = Contour_Half_Matrix {contour_half_matrix_n :: Int ,contour_half_matrix_m :: Matrix Ordering} - deriving (Eq) + deriving (Eq,Ord) -- | Half 'Matrix' of contour given comparison function /f/. -- @@ -183,7 +133,7 @@ -- > 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) +uniform (Contour_Description _ m) = T.all_equal (M.elems m) -- | 'True' if contour does not containt any 'EQ' elements. -- @@ -317,7 +267,7 @@ LT -> i' + adjustment j' EQ -> i' GT -> i' - adjustment j' - in Just (replace ns j j'') + in Just (T.replace_at ns j j'') refine [] ns = ns refine (i:is) ns = case step i ns of Nothing -> refine is ns @@ -330,7 +280,7 @@ -- > 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) + Contour_Description n (M.map T.ord_invert m) -- * Construction @@ -499,5 +449,5 @@ ex_4 = let ns :: [[Int]] ns = [[2,2,2,1],[2,2,0],[0,0],[1]] - ns' = map (map int_to_ord) ns + ns' = map (map T.int_to_ord) ns in half_matrix_to_description (Contour_Half_Matrix 5 ns') diff --git a/Music/Theory/DB/CSV.hs b/Music/Theory/DB/CSV.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/DB/CSV.hs @@ -0,0 +1,24 @@ +-- | Keys are given in the header, empty fields are omitted from records. +module Music.Theory.DB.CSV where + +import Data.Maybe {- base -} +import qualified Text.CSV.Lazy.String as C {- lazy-csv -} + +import Music.Theory.DB.Common {- hmt -} +import qualified Music.Theory.IO as T {- hmt -} + +-- | Load 'DB' from 'FilePath'. +db_load_utf8 :: FilePath -> IO DB' +db_load_utf8 fn = do + s <- T.read_file_utf8 fn + let p = C.fromCSVTable (C.csvTable (C.parseCSV s)) + (h,d) = (head p,tail p) + f k v = if null v then Nothing else Just (k,v) + return (map (catMaybes . zipWith f h) d) + +db_store_utf8 :: FilePath -> DB' -> IO () +db_store_utf8 fn db = do + let (hdr,tbl) = db_to_table (fromMaybe "") db + (_,tbl') = C.toCSVTable (hdr : tbl) + str = C.ppCSVTable tbl' + T.write_file_utf8 fn str diff --git a/Music/Theory/DB/Common.hs b/Music/Theory/DB/Common.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/DB/Common.hs @@ -0,0 +1,130 @@ +module Music.Theory.DB.Common where + +import Data.List {- base -} +import Data.Maybe {- base -} +import Safe {- safe -} + +import qualified Music.Theory.List as T {- base -} +import qualified Music.Theory.Maybe as T {- base -} + +-- * Type + +type Entry k v = (k,v) +type Record k v = [Entry k v] +type DB k v = [Record k v] + +type Key = String +type Value = String +type Entry' = Entry Key Value +type Record' = Record Key Value +type DB' = DB Key Value + +-- * Record + +-- | The sequence of keys at 'Record'. +record_key_seq :: Record k v -> [k] +record_key_seq = map fst + +-- | 'True' if 'Key' is present in 'Entity'. +record_has_key :: Eq k => k -> Record k v -> Bool +record_has_key k = elem k . record_key_seq + +-- | 'T.histogram' of 'record_key_seq'. +record_key_histogram :: Ord k => Record k v -> [(k,Int)] +record_key_histogram = T.histogram . record_key_seq + +-- | Duplicate keys predicate. +record_has_duplicate_keys :: Ord k => Record k v -> Bool +record_has_duplicate_keys = any (> 0) . map snd . record_key_histogram + +-- | Find all associations for key using given equality function. +record_lookup_by :: (k -> k -> Bool) -> k -> Record k v -> [v] +record_lookup_by f k = map snd . filter (f k . fst) + +-- | 'record_lookup_by' of '=='. +record_lookup :: Eq k => k -> Record k v -> [v] +record_lookup = record_lookup_by (==) + +-- | /n/th element of 'record_lookup'. +record_lookup_at :: Eq k => (k,Int) -> Record k v -> Maybe v +record_lookup_at (c,n) = flip atMay n . record_lookup c + +-- | Variant of 'record_lookup' requiring a unique key. 'Nothing' indicates +-- there is no entry, it is an 'error' if duplicate keys are present. +record_lookup_uniq :: Eq k => k -> Record k v -> Maybe v +record_lookup_uniq k r = + case record_lookup k r of + [] -> Nothing + [v] -> Just v + _ -> error "record_lookup_uniq: non uniq" + +-- | 'True' if key exists and is unique. +record_has_key_uniq :: Eq k => k -> Record k v -> Bool +record_has_key_uniq k = isJust . record_lookup_uniq k + +-- | Error variant. +record_lookup_uniq_err :: Eq k => k -> Record k v -> v +record_lookup_uniq_err k = T.from_just "record_lookup_uniq: none" . record_lookup_uniq k + +-- | Default value variant. +record_lookup_uniq_def :: Eq k => v -> k -> Record k v -> v +record_lookup_uniq_def v k = fromMaybe v . record_lookup_uniq k + +-- | Remove all associations for key using given equality function. +record_delete_by :: (k -> k -> Bool) -> k -> Record k v -> Record k v +record_delete_by f k = filter (not . f k . fst) + +-- | 'record_delete_by' of '=='. +record_delete :: Eq k => k -> Record k v -> Record k v +record_delete = record_delete_by (==) + +-- * DB + +-- | Preserves order of occurence. +db_key_set :: Ord k => DB k v -> [k] +db_key_set = nub . map fst . concat + +db_lookup_by :: (k -> k -> Bool) -> (v -> v -> Bool) -> k -> v -> DB k v -> [Record k v] +db_lookup_by k_cmp v_cmp k v = + let f = any (v_cmp v) . record_lookup_by k_cmp k + in filter f + +db_lookup :: (Eq k,Eq v) => k -> v -> DB k v -> [Record k v] +db_lookup = db_lookup_by (==) (==) + +db_has_duplicate_keys :: Ord k => DB k v -> Bool +db_has_duplicate_keys = any id . map record_has_duplicate_keys + +db_key_histogram :: Ord k => DB k v -> [(k,Int)] +db_key_histogram db = + let h = concatMap record_key_histogram db + f k = (k,maximum (record_lookup k h)) + in map f (db_key_set db) + +db_to_table :: Ord k => (Maybe v -> e) -> DB k v -> ([k],[[e]]) +db_to_table f db = + let kh = db_key_histogram db + hdr = concatMap (\(k,n) -> replicate n k) kh + ix = concatMap (\(k,n) -> zip (repeat k) [0 .. n - 1]) kh + in (hdr,map (\r -> map (\i -> f (record_lookup_at i r)) ix) db) + +-- * Collating duplicate keys. + +record_collate' :: Eq k => (k,[v]) -> Record k v -> Record k [v] +record_collate' (k,v) r = + case r of + [] -> [(k,reverse v)] + (k',v'):r' -> + if k == k' + then record_collate' (k,v' : v) r' + else (k,reverse v) : record_collate' (k',[v']) r' + +-- | Collate adjacent entries of existing sequence with equal key. +record_collate :: Eq k => Record k v -> Record k [v] +record_collate r = + case r of + [] -> error "record_collate: nil" + (k,v):r' -> record_collate' (k,[v]) r' + +record_uncollate :: Record k [v] -> Record k v +record_uncollate = concatMap (\(k,v) -> zip (repeat k) v) diff --git a/Music/Theory/DB/JSON.hs b/Music/Theory/DB/JSON.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/DB/JSON.hs @@ -0,0 +1,67 @@ +-- | JSON string association database. +-- JSON objects do no allow multiple keys. +-- Here multiple keys are read & written as arrays. +module Music.Theory.DB.JSON where + +import qualified Data.Aeson as A {- aeson -} +import qualified Data.ByteString.Lazy as B {- bytestring -} +import qualified Data.Map as M {- containers -} + +import qualified Music.Theory.DB.Common as DB + +-- | Load 'DB' from 'FilePath'. +db_load_utf8 :: FilePath -> IO DB.DB' +db_load_utf8 fn = do + b <- B.readFile fn + case A.decode b of + Just m -> + let f = DB.record_uncollate . + map (fmap maybe_list_to_list) . + M.toList + in return (map f m) + Nothing -> return [] + +-- | Store 'DB' to 'FilePath'. +-- +-- > let fn = "/home/rohan/ut/www-spr/data/db.js" +-- > db <- db_load_utf8 fn +-- > length db == 1334 +-- > db_store_utf8 "/tmp/sp.js" db +db_store_utf8 :: FilePath -> DB.DB' -> IO () +db_store_utf8 fn db = do + let db' = let f = map (fmap list_to_maybe_list) . DB.record_collate + in map f db + b = A.encode (map M.fromList db') + B.writeFile fn b + +-- * Maybe List of String + +data Maybe_List_Of_String = S String | L [String] deriving (Eq,Show) + +maybe_list_to_list :: Maybe_List_Of_String -> [String] +maybe_list_to_list m = + case m of + S s -> [s] + L l -> l + +list_to_maybe_list :: [String] -> Maybe_List_Of_String +list_to_maybe_list l = + case l of + [s] -> S s + _ -> L l + +-- > A.toJSON (S "x") +-- > A.toJSON (L ["x","y"]) +instance A.ToJSON Maybe_List_Of_String where + toJSON (S s) = A.toJSON s + toJSON (L l) = A.toJSON l + +-- > :set -XOverloadedStrings +-- > A.decode "\"x\"" :: Maybe Maybe_List_Of_String +-- > A.decode "[\"x\",\"y\"]" :: Maybe Maybe_List_Of_String +instance A.FromJSON Maybe_List_Of_String where + parseJSON v = + case v of + A.String _ -> fmap S (A.parseJSON v) + A.Array _ -> fmap L (A.parseJSON v) + _ -> error "parseJSON: Maybe_List_String" diff --git a/Music/Theory/DB/Plain.hs b/Music/Theory/DB/Plain.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/DB/Plain.hs @@ -0,0 +1,60 @@ +-- | @key: value@ database, allows duplicate @key@s. +module Music.Theory.DB.Plain where + +import Data.List {- base -} +import qualified Data.List.Split as Split {- split -} +import Data.Maybe {- base -} +import qualified Safe as Safe {- safe -} + +import qualified Music.Theory.IO as IO {- hmt -} +import qualified Music.Theory.List as T {- hmt -} + +-- | (RECORD-SEPARATOR,FIELD-SEPARATOR,ENTRY-SEPARATOR) +type SEP = (String,String,String) + +type Key = String +type Value = String +type Entry = (Key,[Value]) +type Record = [Entry] +type DB = [Record] + +sep_plain :: SEP +sep_plain = (['\n','\n'],['\n'],": ") + +-- > record_parse (";","=") "F=f/rec;E=au;C=A;K=P;K=Q" +record_parse :: (String,String) -> String -> Record +record_parse (fs,es) = T.collate_adjacent . mapMaybe (T.separate_at es) . Split.splitOn fs + +record_lookup :: Key -> Record -> [Value] +record_lookup k = fromMaybe [] . lookup k + +record_lookup_at :: (Key,Int) -> Record -> Maybe Value +record_lookup_at (k,n) = flip Safe.atMay n . record_lookup k + +record_has_key :: Key -> Record -> Bool +record_has_key k = isJust . lookup k + +record_lookup_uniq :: Key -> Record -> Maybe Value +record_lookup_uniq k r = + case record_lookup k r of + [] -> Nothing + [v] -> Just v + _ -> error "record_lookup_uniq: non uniq" + +db_parse :: SEP -> String -> [Record] +db_parse (rs,fs,es) s = + let r = Split.splitOn rs s + in map (record_parse (fs,es)) r + +db_sort :: [(Key,Int)] -> [Record] -> [Record] +db_sort k = T.sort_by_n_stage (map record_lookup_at k) + +db_load_utf8 :: SEP -> FilePath -> IO [Record] +db_load_utf8 sep = fmap (db_parse sep) . IO.read_file_utf8 + +-- > record_pp (";","=") [("F","f/rec.au"),("C","A")] +record_pp :: (String,String) -> Record -> String +record_pp (fs,es) = intercalate fs . map (\(k,v) -> k ++ es ++ v) . T.uncollate + +db_store_utf8 :: SEP -> FilePath -> [Record] -> IO () +db_store_utf8 (rs,fs,es) fn = IO.write_file_utf8 fn . intercalate rs . map (record_pp (fs,es)) diff --git a/Music/Theory/Directory.hs b/Music/Theory/Directory.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Directory.hs @@ -0,0 +1,38 @@ +-- | Directory functions. +module Music.Theory.Directory where + +import Data.List {- base -} +import Data.Maybe {- base -} +import System.Directory {- directory -} +import System.FilePath {- filepath -} + +-- | Scan a list of directories until a file is located, or not. +path_scan :: [FilePath] -> FilePath -> IO (Maybe FilePath) +path_scan p fn = + case p of + [] -> return Nothing + dir:p' -> let nm = dir fn + f x = if x then return (Just nm) else path_scan p' fn + in doesFileExist nm >>= f + +path_scan_err :: [FilePath] -> FilePath -> IO FilePath +path_scan_err p x = + let err = (error ("path_scan: " ++ show p ++ ": " ++ x)) + in fmap (fromMaybe err) (path_scan p x) + +-- | 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))) + +-- | If path is not absolute, prepend current working directory. +-- +-- > to_absolute_cwd "x" +to_absolute_cwd :: FilePath -> IO FilePath +to_absolute_cwd x = + if isAbsolute x + then return x + else fmap ( x) getCurrentDirectory + diff --git a/Music/Theory/Duration.hs b/Music/Theory/Duration.hs --- a/Music/Theory/Duration.hs +++ b/Music/Theory/Duration.hs @@ -6,6 +6,9 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Ord as T {- hmt -} + -- | Common music notation durational model data Duration = Duration {division :: Integer -- ^ division of whole note ,dots :: Integer -- ^ number of dots @@ -17,6 +20,10 @@ duration_meq :: Duration -> Duration -> Bool duration_meq p q = multiplier p == multiplier q +-- | Is multiplier the identity (ie. @1@)? +duration_m1 :: Duration -> Bool +duration_m1 = (== 1) . multiplier + -- | Compare durations with equal multipliers. duration_compare_meq :: Duration -> Duration -> Maybe Ordering duration_compare_meq y0 y1 = @@ -40,22 +47,6 @@ 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 @@ -102,100 +93,134 @@ 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))) + in join (fmap f (T.sort_pair_m duration_compare_meq (y0,y1))) -- | Erroring variant of 'sum_dur'. -sum_dur' :: Duration -> Duration -> Duration -sum_dur' y0 y1 = +sum_dur_err :: Duration -> Duration -> Duration +sum_dur_err y0 y1 = let y2 = sum_dur y0 y1 err = error ("sum_dur': " ++ show (y0,y1)) in fromMaybe err y2 --- | Give @MusicXML@ type for division. +-- | Standard divisions (from 0 to 256). MusicXML allows @-1@ as a division (for @long@). +divisions_set :: [Integer] +divisions_set = [0,1,2,4,8,16,32,64,128,256] + +-- | Durations set derived from 'divisions_set' with up to /k/ dots. Multiplier of @1@. +duration_set :: Integer -> [Duration] +duration_set k = [Duration dv dt 1 | dv <- divisions_set, dt <- [0..k]] + +-- | Table of number of beams at notated division. +beam_count_tbl :: [(Integer,Integer)] +beam_count_tbl = zip (-1 : divisions_set) [0,0,0,0,0,1,2,3,4,5,6] + +-- | Lookup 'beam_count_tbl'. -- +-- > 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 = lookup x beam_count_tbl + +-- | Calculate number of beams at 'Duration'. +-- +-- > map duration_beam_count [Duration 2 0 1,Duration 16 0 1] == [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 + +-- * MusicXML + +-- | Table giving @MusicXML@ types for divisions. +division_musicxml_tbl :: [(Integer,String)] +division_musicxml_tbl = + let nm = ["long","breve","whole","half","quarter","eighth" + ,"16th","32nd","64th","128th","256th"] + in zip (-1 : divisions_set) nm + +-- | Lookup 'division_musicxml_tbl'. +-- -- > 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) + T.lookup_err_msg "division_musicxml_tbl" x division_musicxml_tbl -- | Variant of 'whole_note_division_to_musicxml_type' extracting --- 'division' from 'Duration'. +-- 'division' from 'Duration', dots & multipler are ignored. -- --- > duration_to_musicxml_type quarter_note == "quarter" +-- > duration_to_musicxml_type (Duration 4 0 1) == "quarter" duration_to_musicxml_type :: Duration -> String duration_to_musicxml_type = whole_note_division_to_musicxml_type . division +-- * Unicode + +-- | Table giving @Unicode@ symbols for divisions. +division_unicode_tbl :: [(Integer,Char)] +division_unicode_tbl = zip [0,1,2,4,8,16,32,64,128,256] "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲" + +-- | Lookup 'division_unicode_tbl'. +-- +-- > map whole_note_division_to_unicode_symbol [1,2,4,8] == "𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮" +whole_note_division_to_unicode_symbol :: Integer -> Char +whole_note_division_to_unicode_symbol x = + T.lookup_err_msg "division_unicode_tbl" x division_unicode_tbl + +-- | Give Unicode string for 'Duration'. The duration multiplier is /not/ written. +-- +-- > map duration_to_unicode [Duration 1 2 1,Duration 4 1 1] == ["𝅝𝅭𝅭","𝅘𝅥𝅭"] +duration_to_unicode :: Duration -> String +duration_to_unicode (Duration dv d _) = + let dv' = whole_note_division_to_unicode_symbol dv + in dv' : replicate (fromIntegral d) '𝅭' + +-- * Lilypond + -- | 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."] +-- > map duration_to_lilypond_type [Duration 2 0 1,Duration 4 1 1] == ["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 +-- * Humdrum --- | 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 +{- | Duration to @**recip@ notation. -whole_note_division_pp :: Integer -> Maybe Char -whole_note_division_pp x = + + +> 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)) + +-- * Letter + +whole_note_division_letter_pp :: Integer -> Maybe Char +whole_note_division_letter_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) = +-- > mapMaybe duration_letter_pp [Duration 4 0 1,Duration 2 1 1,Duration 8 2 1] == ["q","h'","e''"] +-- > duration_letter_pp +duration_letter_pp :: Duration -> Maybe String +duration_letter_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 + in case whole_note_division_letter_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)) diff --git a/Music/Theory/Duration/Annotation.hs b/Music/Theory/Duration/Annotation.hs --- a/Music/Theory/Duration/Annotation.hs +++ b/Music/Theory/Duration/Annotation.hs @@ -3,11 +3,11 @@ 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 +import qualified Music.Theory.List as L {- hmt -} -- | Standard music notation durational model annotations data D_Annotation = Tie_Right @@ -63,52 +63,6 @@ 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'. -- @@ -121,9 +75,7 @@ -- > ,(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 +da_group_tuplets = L.group_tree (da_begins_tuplet,da_ends_tuplet) -- | Variant of 'break' that places separator at left. -- @@ -165,22 +117,11 @@ 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 (,) +zip_kr = L.zip_with_kr (,) -- | 'zipWith' variant that adopts the shape of the lhs. -- @@ -192,31 +133,9 @@ 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 + Right j -> let (j',q'') = L.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) diff --git a/Music/Theory/Duration/CT.hs b/Music/Theory/Duration/CT.hs --- a/Music/Theory/Duration/CT.hs +++ b/Music/Theory/Duration/CT.hs @@ -124,7 +124,7 @@ 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 + let dv' = concatMap (zip [1::Int ..]) dv f (p,rq,(g,du)) = let nm = if p == 1 then case mk of @@ -134,7 +134,7 @@ 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') + in map f (zip3 [1::Int ..] mrq dv') -- | Click track definition. data CT = CT {ct_len :: Int diff --git a/Music/Theory/Duration/Name/Abbreviation.hs b/Music/Theory/Duration/Name/Abbreviation.hs --- a/Music/Theory/Duration/Name/Abbreviation.hs +++ b/Music/Theory/Duration/Name/Abbreviation.hs @@ -2,7 +2,8 @@ -- 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'. +-- dotted 'eighth_note'. The prefix is @_@ not @d@ since @d4@ etc. are +-- also note names. -- -- > 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] diff --git a/Music/Theory/Duration/RQ.hs b/Music/Theory/Duration/RQ.hs --- a/Music/Theory/Duration/RQ.hs +++ b/Music/Theory/Duration/RQ.hs @@ -6,36 +6,22 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import Music.Theory.Duration -import Music.Theory.Duration.Name +import Music.Theory.Duration {- hmt -} -- | Rational Quarter-Note type RQ = Rational +-- > rq_duration_tbl 2 +rq_duration_tbl :: Integer -> [(Rational,Duration)] +rq_duration_tbl k = map (\d -> (duration_to_rq d,d)) (duration_set k) + -- | 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 +rq_to_duration x = lookup x (rq_duration_tbl 2) -- | Is 'RQ' a /cmn/ duration. -- diff --git a/Music/Theory/Duration/Sequence/Notate.hs b/Music/Theory/Duration/Sequence/Notate.hs --- a/Music/Theory/Duration/Sequence/Notate.hs +++ b/Music/Theory/Duration/Sequence/Notate.hs @@ -17,7 +17,6 @@ -- 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 -} @@ -646,6 +645,14 @@ z i (j,_) = i + duration_to_rq j in coalesce_sum z 0 f +-- | Run simplifier until it reaches a fix-point, or for at most 'limit' passes. +m_simplify_fix :: Int -> Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A] +m_simplify_fix limit p ts d = + let d' = m_simplify p ts d + in if d == d' || limit == 1 + then d' + else m_simplify_fix (limit - 1) p ts d' + -- | Pulse simplifier predicate, which is 'const' 'True'. p_simplify_rule :: Simplify_P p_simplify_rule = const True @@ -674,23 +681,23 @@ > 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 +> in T.notate_rqp 4 sr ts (Just ts_p) rq -} -notate_rqp :: Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> +notate_rqp :: Int -> Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> Either String [[Duration_A]] -notate_rqp r ts ts_p x = do +notate_rqp limit 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) + return (zipWith (m_simplify_fix limit 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] -> +-- > notate 4 (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6] +notate :: Int -> Simplify_P -> [Time_Signature] -> [RQ] -> Either String [[Duration_A]] -notate r ts x = notate_rqp r ts Nothing x +notate limit r ts x = notate_rqp limit r ts Nothing x -- * Ascribe @@ -772,17 +779,17 @@ in r : mm_ascribe mm' x' -- | 'mm_ascribe of 'notate'. -notate_mm_ascribe :: Show a => [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] -> +notate_mm_ascribe :: Show a => Int -> [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 +notate_mm_ascribe limit r ts rqp d p = + let n = notate_rqp limit (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] -> +notate_mm_ascribe_err :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] -> [[(Duration_A,a)]] -notate_mm_ascribe_err = either error id .:::: notate_mm_ascribe +notate_mm_ascribe_err = either error id .::::: notate_mm_ascribe -- | Group elements as /chords/ where a chord element is indicated by -- the given predicate. diff --git a/Music/Theory/Dynamic_Mark.hs b/Music/Theory/Dynamic_Mark.hs --- a/Music/Theory/Dynamic_Mark.hs +++ b/Music/Theory/Dynamic_Mark.hs @@ -33,7 +33,7 @@ -- | 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 :: (Ord 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) diff --git a/Music/Theory/Enum.hs b/Music/Theory/Enum.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Enum.hs @@ -0,0 +1,38 @@ +-- | Enumeration functions. +module Music.Theory.Enum where + +-- | 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 + +-- | Variant of 'enumFromTo' that, if /p/ is after /q/, cycles from +-- 'maxBound' to 'minBound'. +-- +-- > import Data.Word +-- > enum_from_to_cyclic (254 :: Word8) 1 == [254,255,0,1] +enum_from_to_cyclic :: (Bounded a, Enum a) => a -> a -> [a] +enum_from_to_cyclic p q = + if fromEnum p > fromEnum q + then [p .. maxBound] ++ [minBound .. q] + else [p .. q] + +-- | Variant of 'enumFromTo' that, if /p/ is after /q/, enumerates +-- from /q/ to /p/. +-- +-- > enum_from_to_reverse 5 1 == [5,4,3,2,1] +-- > enum_from_to_reverse 1 5 == enumFromTo 1 5 +enum_from_to_reverse :: Enum a => a -> a -> [a] +enum_from_to_reverse p q = + if fromEnum p > fromEnum q + then reverse [q .. p] + else [p .. q] + +-- | All elements in sequence. +-- +-- > (enum_univ :: [Data.Word.Word8]) == [0 .. 255] +enum_univ :: (Bounded t,Enum t) => [t] +enum_univ = [minBound .. maxBound] diff --git a/Music/Theory/Function.hs b/Music/Theory/Function.hs --- a/Music/Theory/Function.hs +++ b/Music/Theory/Function.hs @@ -1,6 +1,13 @@ -- | "Data.Function" related functions. module Music.Theory.Function where +-- | 'const' of 'const'. +-- +-- > const2 5 undefined undefined == 5 +-- > const (const 5) undefined undefined == 5 +const2 :: a -> b -> c -> a +const2 x _ _ = x + -- * Predicate composition. -- | '&&' of predicates. @@ -18,7 +25,7 @@ predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool predicate_or f g x = f x || g x --- | 'any' of predicates. +-- | 'any' of predicates, ie. logical /or/ of list of predicates. -- -- > let r = [True,False,True,False,True,True] -- > in map (predicate_any [(== 0),(== 5),even]) [0..5] == r diff --git a/Music/Theory/Gamelan.hs b/Music/Theory/Gamelan.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Gamelan.hs @@ -0,0 +1,325 @@ +module Music.Theory.Gamelan where + +import Data.Char {- base -} +import Data.Function {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} +import Text.Printf {- base -} + +import qualified Music.Theory.Clef as T {- hmt -} +import qualified Music.Theory.Enum as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuning.ET as T {- hmt-diagrams -} + +-- | 'fromJust' with error message. +fromJust_err :: String -> Maybe a -> a +fromJust_err err = fromMaybe (error err) + +-- | 'approxRational' of 0.01. +near_rat :: Double -> Rational +near_rat = flip approxRational 0.01 + +-- * Gamelan + +-- | Enumeration of gamelan instrument families. +data Instrument_Family + = Bonang + | Gender + | Gong + | Saron + deriving (Enum,Bounded,Eq,Ord,Show,Read) + +-- | Universe +instrument_family_set :: [Instrument_Family] +instrument_family_set = T.enum_univ + +-- | Enumeration of Gamelan instruments. +data Instrument_Name + = Bonang_Barung -- ^ Bonang Barung (horizontal gong, middle) + | Bonang_Panerus -- ^ Bonang Panerus (horizontal gong, high) + | Gender_Barung -- ^ Gender Barung (key&resonator, middle) + | Gender_Panerus -- ^ Gender Panembung (key&resonator, high) + | Gender_Panembung -- ^ Gender Panembung, Slenthem (key&resonator, low) + | Gong_Ageng -- ^ Gong Ageng (hanging gong, low) + | Gong_Suwukan -- ^ Gong Suwukan (hanging gong, middle) + | Kempul -- ^ Kempul (hanging gong, middle) + | Kempyang -- ^ Kempyang (horizontal gong, high) + | Kenong -- ^ Kenong (horizontal gong, low) + | Ketuk -- ^ Ketuk (horizontal gong, middle) + | Saron_Barung -- ^ Saron Barung, Saron (key, middle) + | Saron_Demung -- ^ Saron Demung, Demung (key, low) + | Saron_Panerus -- ^ Saron Panerus, Peking (key, high) + deriving (Enum,Bounded,Eq,Ord,Show,Read) + +instrument_family :: Instrument_Name -> Maybe Instrument_Family +instrument_family nm = + case nm of + Bonang_Barung -> Just Bonang + Bonang_Panerus -> Just Bonang + Gender_Barung -> Just Gender + Gender_Panerus -> Just Gender + Gender_Panembung -> Just Gender + Gong_Ageng -> Just Gong + Gong_Suwukan -> Just Gong + Kempul -> Just Gong + Kempyang -> Nothing + Kenong -> Nothing + Ketuk -> Nothing + Saron_Barung -> Just Saron + Saron_Demung -> Just Saron + Saron_Panerus -> Just Saron + +instrument_name_pp :: Instrument_Name -> String +instrument_name_pp = + let f c = if c == '_' then ' ' else c + in map f . show + +-- | 'Clef' appropriate for 'Instrument_Name'. +instrument_name_clef :: Integral i => Instrument_Name -> T.Clef i +instrument_name_clef nm = + case nm of + Bonang_Barung -> T.Clef T.Treble 0 + Bonang_Panerus -> T.Clef T.Treble 1 + Gender_Barung -> T.Clef T.Treble 0 + Gender_Panerus -> T.Clef T.Treble 1 + Gender_Panembung -> T.Clef T.Bass 0 + Gong_Ageng -> T.Clef T.Bass 0 + Gong_Suwukan -> T.Clef T.Bass 0 + Kempul -> T.Clef T.Bass 0 + Kempyang -> T.Clef T.Treble 1 + Kenong -> T.Clef T.Treble 0 + Ketuk -> T.Clef T.Alto 0 + Saron_Barung -> T.Clef T.Treble 0 + Saron_Demung -> T.Clef T.Treble 0 + Saron_Panerus -> T.Clef T.Treble 1 + +instrument_name_clef_plain :: Integral i => Instrument_Name -> T.Clef i +instrument_name_clef_plain = T.clef_zero . instrument_name_clef + +-- | Enumeration of Gamelan scales. +data Scale = Pelog | Slendro deriving (Enum,Eq,Ord,Show,Read) + +type Octave = Integer +type Degree = Integer +type Frequency = Double +type Annotation = String + +data Pitch = Pitch {pitch_octave :: Octave + ,pitch_degree :: Degree} + deriving (Eq,Ord,Show) + +pitch_pp_ascii :: Pitch -> String +pitch_pp_ascii (Pitch o d) = + let d' = intToDigit (fromIntegral d) + o' = if o < 0 + then genericReplicate (abs o) '-' + else genericReplicate o '+' + in o' ++ [d'] + +pitch_pp_duple :: Pitch -> String +pitch_pp_duple (Pitch o d) = printf "(%d,%d)" o d + +data Note = Note {note_scale :: Scale + ,note_pitch :: Pitch} + deriving (Eq,Ord,Show) + +note_degree :: Note -> Degree +note_degree = pitch_degree . note_pitch + +data Tone = Tone {tone_instrument_name :: Instrument_Name + ,tone_note :: Maybe Note + ,tone_frequency :: Maybe Frequency + ,tone_annotation :: Maybe Annotation} + deriving (Eq,Show) + +tone_frequency_err :: Tone -> Frequency +tone_frequency_err = fromJust_err "tone_frequency" . tone_frequency + +-- | Orderable if frequency is given. +instance Ord Tone where compare = tone_compare_frequency + +-- | Constructor for 'Tone' without /frequency/ or /annotation/. +plain_tone :: Instrument_Name -> Scale -> Octave -> Degree -> Tone +plain_tone nm sc o d = Tone nm (Just (Note sc (Pitch o d))) Nothing Nothing + +-- | Tones are considered /equivalent/ if they have the same +-- 'Instrument_Name' and 'Note'. +tone_equivalent :: Tone -> Tone -> Bool +tone_equivalent p q = + let Tone nm nt _ _ = p + Tone nm' nt' _ _ = q + in nm == nm' && nt == nt' + +tone_24et_pitch :: Tone -> Maybe T.Pitch +tone_24et_pitch = + let f i = let (_,pt,_,_,_) = T.nearest_24et_tone i in pt + in fmap f . tone_frequency + +tone_24et_pitch' :: Tone -> T.Pitch +tone_24et_pitch' = fromJust_err "tone_24et_pitch" . tone_24et_pitch + +tone_24et_pitch_detune :: Tone -> Maybe T.Pitch_Detune +tone_24et_pitch_detune = fmap T.nearest_pitch_detune_24et . tone_frequency + +tone_24et_pitch_detune' :: Tone -> T.Pitch_Detune +tone_24et_pitch_detune' = fromJust_err "tone_24et_pitch_detune" . tone_24et_pitch_detune + +tone_fmidi :: Tone -> Double +tone_fmidi = T.cps_to_fmidi . tone_frequency_err + +-- | Fractional (rational) 24-et midi note number of 'Tone'. +tone_24et_fmidi :: Tone -> Rational +tone_24et_fmidi = near_rat . T.pitch_to_fmidi . tone_24et_pitch' + +tone_12et_pitch :: Tone -> Maybe T.Pitch +tone_12et_pitch = + let f i = let (_,pt,_,_,_) = T.nearest_12et_tone i in pt + in fmap f . tone_frequency + +tone_12et_pitch' :: Tone -> T.Pitch +tone_12et_pitch' = fromJust_err "tone_12et_pitch" . tone_12et_pitch + +tone_12et_pitch_detune :: Tone -> Maybe T.Pitch_Detune +tone_12et_pitch_detune = fmap T.nearest_pitch_detune_12et . tone_frequency + +tone_12et_pitch_detune' :: Tone -> T.Pitch_Detune +tone_12et_pitch_detune' = fromJust_err "tone_12et_pitch_detune" . tone_12et_pitch_detune + +-- | Fractional (rational) 24-et midi note number of 'Tone'. +tone_12et_fmidi :: Tone -> Rational +tone_12et_fmidi = near_rat . T.pitch_to_fmidi . tone_12et_pitch' + +tone_family :: Tone -> Maybe Instrument_Family +tone_family = instrument_family . tone_instrument_name + +tone_family_err :: Tone -> Instrument_Family +tone_family_err = fromJust_err "tone_family" . tone_family + +tone_in_family :: Instrument_Family -> Tone -> Bool +tone_in_family c t = tone_family t == Just c + +select_tones :: Instrument_Family -> [Tone] -> [Maybe Tone] +select_tones c = + let f t = if tone_family t == Just c then Just t else Nothing + in map f + +-- | Specify subset as list of families and scales. +type Tone_Subset = ([Instrument_Family],[Scale]) + +-- | Extract subset of 'Tone_Set'. +tone_subset :: Tone_Subset -> Tone_Set -> Tone_Set +tone_subset (fm,sc) = + let f t = fromJust_err "tone_subset" (tone_family t) `elem` fm && + fromJust_err "tone_subset" (tone_scale t) `elem` sc + in filter f + +data Instrument = Instrument {instrument_name :: Instrument_Name + ,instrument_scale :: Maybe Scale + ,instrument_pitches :: Maybe [Pitch] + ,instrument_frequencies :: Maybe [Frequency]} + deriving (Eq,Show) + +type Tone_Set = [Tone] +type Tone_Group = [Tone_Set] +type Gamelan = [Instrument] + +tone_scale :: Tone -> Maybe Scale +tone_scale = fmap note_scale . tone_note + +tone_pitch :: Tone -> Maybe Pitch +tone_pitch = fmap note_pitch . tone_note + +tone_degree :: Tone -> Maybe Degree +tone_degree = fmap pitch_degree . tone_pitch + +tone_degree' :: Tone -> Degree +tone_degree' = fromJust_err "tone_degree" . tone_degree + +tone_octave :: Tone -> Maybe Octave +tone_octave = fmap pitch_octave . tone_pitch + +tone_class :: Tone -> (Instrument_Name,Maybe Scale) +tone_class t = (tone_instrument_name t,tone_scale t) + +instrument_class :: Instrument -> (Instrument_Name,Maybe Scale) +instrument_class i = (instrument_name i,instrument_scale i) + +tone_class_p :: (Instrument_Name, Scale) -> Tone -> Bool +tone_class_p (nm,sc) t = + tone_instrument_name t == nm && + tone_scale t == Just sc + +tone_family_class_p :: (Instrument_Family,Scale) -> Tone -> Bool +tone_family_class_p (fm,sc) t = + instrument_family (tone_instrument_name t) == Just fm && + tone_scale t == Just sc + +-- | Given a 'Tone_Set', find those 'Tone's that are within 'T.Cents' of 'Frequency'. +tone_set_near_frequency :: Tone_Set -> T.Cents -> Frequency -> Tone_Set +tone_set_near_frequency t k n = + let near i = abs (T.cps_difference_cents i n) <= k + near_t i = maybe False near (tone_frequency i) + in filter near_t t + +-- | Compare 'Tone's by frequency. 'Tone's without frequency compare +-- as if at frequency @0@. +tone_compare_frequency :: Tone -> Tone -> Ordering +tone_compare_frequency = compare `on` (maybe 0 id . tone_frequency) + +-- | If all /f/ of /a/ are 'Just' /b/, then 'Just' /[b]/, else +-- 'Nothing'. +map_maybe_uniform :: (a -> Maybe b) -> [a] -> Maybe [b] +map_maybe_uniform f x = + let x' = map f x + in if any isNothing x' then Nothing else Just (catMaybes x') + +instrument :: Tone_Set -> Instrument +instrument c = + let sf = fmap note_scale . tone_note + pf = fmap note_pitch . tone_note + pm = map_maybe_uniform pf c + fm = map_maybe_uniform tone_frequency c + (p,f) = case (pm,fm) of + (Just i,Just j) -> let (i',j') = unzip (sort (zip i j)) + in (Just i',Just j') + _ -> (pm,fm) + in case c of + t:_ -> Instrument (tone_instrument_name t) (sf t) p f + [] -> undefined + +instruments :: Tone_Set -> [Instrument] +instruments c = + let c' = sortBy (compare `on` tone_instrument_name) c + c'' = groupBy ((==) `on` tone_class) c' + in map instrument c'' + +instrument_gamut :: Instrument -> Maybe (Pitch,Pitch) +instrument_gamut = + let f p = (head p,last p) + in fmap f . instrument_pitches + +scale_degrees :: Scale -> [Degree] +scale_degrees s = + case s of + Pelog -> [1..7] + Slendro -> [1,2,3,5,6] + +-- > degree_index Slendro 4 == Nothing +-- > degree_index Pelog 4 == Just 3 +degree_index :: Scale -> Degree -> Maybe Int +degree_index s d = findIndex (== d) (scale_degrees s) + +-- * Tone set + +tone_set_gamut :: Tone_Set -> Maybe (Pitch,Pitch) +tone_set_gamut g = + case mapMaybe (fmap note_pitch . tone_note) g of + [] -> Nothing + p -> Just (minimum p,maximum p) + +tone_set_instrument :: Tone_Set -> (Instrument_Name,Maybe Scale) -> Tone_Set +tone_set_instrument db (i,s) = + let f t = tone_class t == (i,s) + in filter f db diff --git a/Music/Theory/Graph/Deacon_1934.hs b/Music/Theory/Graph/Deacon_1934.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Deacon_1934.hs @@ -0,0 +1,131 @@ +-- | Geometrical Drawings +-- +-- A. Bernard Deacon and Camilla H. Wedgwood. “Geometrical Drawings +-- from Malekula and Other Islands of the New Hebrides”. The Journal +-- of the Royal Anthropological Institute of Great Britain and +-- Ireland, 64:129—175, 1934. +module Music.Theory.Graph.Deacon_1934 where + +import Data.List {- base -} + +import qualified Music.Theory.Array.Cell_Ref as T {- hmt -} +import qualified Music.Theory.Array.Direction as T {- hmt -} +import qualified Music.Theory.Graph.Dot as T {- hmt -} +import qualified Music.Theory.Graph.FGL as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} + +gen_graph :: Ord v => [T.DOT_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String] +gen_graph opt pp es = T.g_to_udot opt pp (T.g_from_edges_l es) + +gen_graph_ul :: Ord v => [T.DOT_ATTR] -> (v -> String) -> [T.EDGE v] -> [String] +gen_graph_ul opt pp es = T.g_to_udot opt (T.gr_pp_lift_node_f pp) (T.g_from_edges es) + +gen_digraph :: Ord v => [T.DOT_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String] +gen_digraph opt pp es = T.g_to_dot T.G_DIGRAPH opt pp Nothing (T.g_from_edges_l es) + +type G = (T.GRAPH String,[T.DOT_ATTR],FilePath) + +-- * E +g1 :: G +g1 = + let c1 = words "A1 B2 A3 B4 C3 B2 C1 D2 C3 D4 D3 D2 D1 C2 D3 C4 B3 C2 B1 A2 B3 A4 A3 A2 A1" + o1 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")] + in (T.adj2 1 c1,o1,"E") + +-- * D +g2 :: G +g2 = + let c2' = words "B3 C2 = C3 B2 A1 = A2 B1 C2 = C1 B2 A3 = A2 B3 C3 C2 B2 B3 ~ C3 ~ C2 C1 == C3 C2 C1 B1 B2 C2 ~ C1 ~ B1 A1 C1 B1 A1 A2 B2 B1 ~ A1 ~ A2 A3 == A1 A2 A3 B3 B2 A2 ~ A3 ~ B3 C3 C3 ~~ C1 ~~ A1 ~~ A3 A3 B3" + c2 = filter T.is_cell_ref c2' + o2 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c2,o2,"D") + +-- * A +g4 :: G +g4 = + let c4' = words "B1 C2 C3 B3 B2 C2 ~~ C3 C2 ~~ C1 C2 C2 B3 A3 A2 B2 B3 ~~ A3 B3 ~~ C3 B3 B3 A2 A1 B1 B2 A2 ~~ A1 A2 ~~ A3 A2 A2 B1 C1 C2 B2 B1 ~~ C1 B1 ~~ A1 B1 B1" + c4 = filter T.is_cell_ref c4' + o4 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c4,o4,"A") + +g6 :: G +g6 = + let c6' = words "B1 C2 B2 C1 B1 A2 B2 A1 B1 B2 B3 B3 B3 B3 B2 B1 B0 B0 B0 B0 B1 C1 ~~~ C2 B2 B2 B2 A2 ~~~ A1 B1 B1 B1" + c6 = filter T.is_cell_ref c6' + o6 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c6,o6,"B") + +g8 :: G +g8 = + let c8' = words "C2 B1 B1 A2 ~ (04) B1 B2 B3 ~ (08) C2 B3 B3 A2 ~ (13) B3 B2 A2 (17) A3 A3 B2 C1 C1 C2 B2 B1 ~ (23) C2 B2 A2 A1 A1 B2 C3 C3 C2" + c8 = filter T.is_cell_ref c8' + o8 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c8,o8,"C") + +g9 :: G +g9 = + let d9' = ("E6",words "U R D LL (03/D6) U R R U L D D LL (11/C6) U R R U U R D L L D D LL (22/B6) U R R U U R R U L D D L L D D LL (38/A6) U R R U U R R U U R D L L D D L L D D LUU (56/A4) R R U U R R U L D D L L D D L UU (71/A3) R R U U R D L L D D L UU (83/A2) R R U L D D L UU (91/A1) R D L") + d9 = (fst d9',filter T.is_direction (snd d9')) + c9 = T.dir_seq_to_cell_seq d9 + o9 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")] + in (T.adj2 1 c9,o9,"F") + +g10 :: G +g10 = + let d10' = ("B7",words "U R LL (03/A6) R R U L D D LUU (10/A5) R R U L D D L UU (18/A4) R R U L D D L UU (26/A3) R R U L D D L UU (34/A2) R R U L D D L UU (41/A1) R D L") + d10 = (fst d10',filter T.is_direction (snd d10')) + c10 = T.dir_seq_to_cell_seq d10 + e10 = T.adj2 1 c10 + o10 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")] + in (e10,o10,"G") + +g11 :: G +g11 = + let d11' = ("C3",words "DR DDL UUR U L (05/C3) DL DDR UUL U R (10/C3) D D U UL UUR DDL (16/B3) DL R U (18/B3) L DR R (21/C4) UR UUL DDR DR L (26/D4) U R DL L U (31/C3) U D (33/C3) R UUR DDDDD UUL L . (40/C4) L DDL UUUUU DDR R (44/C3)") + d11 = (fst d11',filter T.is_direction (snd d11')) + c11 = T.dir_seq_to_cell_seq d11 + e11 = T.adj2 1 c11 + o11 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")] + in (e11,o11,"H") + +g12 :: G +g12 = + let d12' = ("C2",words "DR UR (02/E2) L DL UL L (06/A2) DR UR UR DR (10/E2) L UL DL L (14/A2) UR DR (16/C2)") + d12 = (fst d12',filter T.is_direction (snd d12')) + c12 = T.dir_seq_to_cell_seq d12 + e12 = T.adj2 1 c12 + o12 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")] + in (e12,o12,"I") + +g13 :: G +g13 = + let d13' = ("B3",words "U D D U R DDL UUL R (07/C3) R UU DDL L UU DDR (11/C3)") + d13 = (fst d13',filter T.is_direction (snd d13')) + c13 = T.dir_seq_to_cell_seq d13 + e13 = T.adj2 1 c13 + o13 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")] + in (e13,o13,"J") + +g_all :: [G] +g_all = [g1,g2,g4,g6,g8,g9,g10,g11,g12,g13] + +-- G = unlabeled, GL = labeled +-- GC = collated, GF = filtered (unique edges) +-- GD = directed +wr :: G -> IO () +wr (e,o,nm) = do + let mk_nm ty = "/home/rohan/sw/hmt/data/dot/deacon/" ++ nm ++ "_" ++ ty ++ ".dot" + wr_f ty g = writeFile (mk_nm ty) (unlines g) + wr_f "G" (gen_graph_ul o id e) + wr_f "GL" (gen_graph o T.gr_pp_id_show (T.e_label_seq e)) + wr_f "GC" (gen_graph o T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e))) + wr_f "GF" (gen_graph_ul o id (nub (map T.t2_sort e))) + wr_f "GD" (gen_digraph o T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e))) +{- + let o' = ("graph:layout","fdp") : o + wr_f "GC_" (gen_graph o' T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e))) +-} + +wr_all :: IO () +wr_all = mapM_ wr g_all diff --git a/Music/Theory/Graph/Dot.hs b/Music/Theory/Graph/Dot.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Dot.hs @@ -0,0 +1,131 @@ +-- | Graph (dot) functions. +module Music.Theory.Graph.Dot where + +import Data.Char {- base -} +import Data.List {- base -} + +import qualified Data.Graph.Inductive.Graph as G {- fgl -} +import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -} + +import qualified Music.Theory.List as T {- hmt -} + +-- * UTIL + +-- | Separate at element. +-- +-- > sep1 ':' "graph:layout" +sep1 :: Eq t => t -> [t] -> ([t],[t]) +sep1 e l = + case break (== e) l of + (p,_:q) -> (p,q) + _ -> error "sep1" + +-- | Quote /s/ if it includes white space. +-- +-- > map maybe_quote ["abc","a b c"] == ["abc","\"a b c\""] +maybe_quote :: String -> String +maybe_quote s = if any isSpace s then concat ["\"",s,"\""] else s + +-- | Left biased union of association lists /p/ and /q/. +-- +-- > assoc_union [(5,"a"),(3,"b")] [(5,"A"),(7,"C")] == [(5,"a"),(3,"b"),(7,"C")] +assoc_union :: Eq k => [(k,v)] -> [(k,v)] -> [(k,v)] +assoc_union p q = + let p_k = map fst p + q' = filter ((`notElem` p_k) . fst) q + in p ++ q' + +-- * ATTR + +-- | area:opt (area = graph|node|edge) +type DOT_KEY = String +type DOT_OPT = String +type DOT_VALUE = String +type DOT_ATTR = (DOT_OPT,DOT_VALUE) +type DOT_ATTR_SET = (String,[DOT_ATTR]) + +-- > dot_key_sep "graph:layout" +dot_key_sep :: String -> (String,String) +dot_key_sep = sep1 ':' + +dot_attr_pp :: DOT_ATTR -> String +dot_attr_pp (lhs,rhs) = concat [lhs,"=",maybe_quote rhs] + +dot_attr_set_pp :: DOT_ATTR_SET -> String +dot_attr_set_pp (ty,opt) = concat [ty," [",intercalate "," (map dot_attr_pp opt),"];"] + +dot_attr_collate :: [DOT_ATTR] -> [DOT_ATTR_SET] +dot_attr_collate opt = + let f (k,v) = let (ty,nm) = dot_key_sep k in (ty,(nm,v)) + c = map f opt + in T.collate c + +dot_attr_ext :: [DOT_ATTR] -> [DOT_ATTR] -> [DOT_ATTR] +dot_attr_ext = assoc_union + +-- > map dot_attr_set_pp (dot_attr_collate dot_attr_def) +dot_attr_def :: [DOT_ATTR] +dot_attr_def = + [("graph:layout","neato") + ,("graph:epsilon","0.000001") + ,("node:shape","plaintext") + ,("node:fontsize","10") + ,("node:fontname","century schoolbook")] + +-- * GRAPH + +-- | Graph pretty-printer, (node->shape,node->label,edge->label) +type GR_PP v e = (v -> Maybe String,v -> Maybe String,e -> Maybe String) + +gr_pp_lift_node_f :: (v -> String) -> GR_PP v e +gr_pp_lift_node_f f = (const Nothing, Just . f, const Nothing) + +gr_pp_id_show :: Show e => GR_PP String e +gr_pp_id_show = (const Nothing,Just . id,Just . show) + +-- | br = brace, csl = comma separated list +br_csl_pp :: Show t => [t] -> String +br_csl_pp l = + case l of + [e] -> show e + _ -> T.bracket ('{','}') (intercalate "," (map show l)) + +gr_pp_id_br_csl :: Show e => GR_PP String [e] +gr_pp_id_br_csl = (const Nothing,Just . id,Just . br_csl_pp) + +-- | Graph type, directed or un-directed. +data G_TYPE = G_DIGRAPH | G_UGRAPH + +g_type_to_string :: G_TYPE -> String +g_type_to_string ty = + case ty of + G_DIGRAPH -> "digraph" + G_UGRAPH -> "graph" + +g_type_to_edge_symbol :: G_TYPE -> String +g_type_to_edge_symbol ty = + case ty of + G_DIGRAPH -> " -> " + G_UGRAPH -> " -- " + +-- | Vertex position function. +type POS_FN v = (v -> (Int,Int)) + +g_to_dot :: G_TYPE -> [DOT_ATTR] -> GR_PP v e -> Maybe (POS_FN v) -> G.Gr v e -> [String] +g_to_dot g_typ opt (n_sh,n_pp,e_pp) pos_f gr = + let p_f (c,r) = concat [",pos=\"",show (c * 100),",",show (r * 100),"\""] + l_f p x = concat [" [label=\"",x,"\"",p,"]"] + n_f (k,n) = let p = maybe "" (\f -> p_f (f n)) pos_f + p' = maybe p (\z -> p ++ ",shape=\"" ++ z ++ "\"") (n_sh n) + a = maybe "" (l_f p') (n_pp n) + in concat [show k,a,";"] + e_f (lhs,rhs,e) = let l = maybe "" (l_f "") (e_pp e) + in concat [show lhs,g_type_to_edge_symbol g_typ,show rhs,l,";"] + in concat [[g_type_to_string g_typ," g {"] + ,map dot_attr_set_pp (dot_attr_collate (assoc_union opt dot_attr_def)) + ,map n_f (G.labNodes gr) + ,map e_f (G.labEdges gr) + ,["}"]] + +g_to_udot :: [DOT_ATTR] -> GR_PP v e -> G.Gr v e -> [String] +g_to_udot o pp = g_to_dot G_UGRAPH o pp Nothing diff --git a/Music/Theory/Graph/FGL.hs b/Music/Theory/Graph/FGL.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/FGL.hs @@ -0,0 +1,141 @@ +-- | Graph (fgl) functions. +module Music.Theory.Graph.FGL where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Data.Map as M {- containers -} + +import qualified Data.Graph.Inductive.Graph as G {- fgl -} +import qualified Data.Graph.Inductive.Query as G {- fgl -} +import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -} + +import qualified Control.Monad.Logic as L {- logict -} + +import qualified Music.Theory.List as T {- hmt -} + +-- | Synonym for 'G.noNodes'. +g_degree :: G.Gr v e -> Int +g_degree = G.noNodes + +-- | 'G.subgraph' of each of 'G.components'. +g_partition :: G.Gr v e -> [G.Gr v e] +g_partition gr = map (\n -> G.subgraph n gr) (G.components gr) + +-- | Find first 'G.Node' with given label. +g_node_lookup :: (Eq v,G.Graph gr) => gr v e -> v -> Maybe G.Node +g_node_lookup gr l = fmap fst (find ((== l) . snd) (G.labNodes gr)) + +-- | Erroring variant. +g_node_lookup_err :: (Eq v,G.Graph gr) => gr v e -> v -> G.Node +g_node_lookup_err gr = fromMaybe (error "g_node_lookup") . g_node_lookup gr + +-- | Set of nodes with given labels, plus all neighbours of these nodes. +-- (impl = implications) +ug_node_set_impl :: (Eq v,G.DynGraph gr) => gr v e -> [v] -> [G.Node] +ug_node_set_impl gr nl = + let n = map (g_node_lookup_err gr) nl + in nub (sort (n ++ concatMap (G.neighbors gr) n)) + +-- * Hamiltonian + +type G_NODE_SEL_F v e = G.Gr v e -> G.Node -> [G.Node] + +-- | 'L.msum' '.' 'map' 'return'. +ml_from_list :: L.MonadLogic m => [t] -> m t +ml_from_list = L.msum . map return + +-- | Use /sel_f/ of 'G.pre' for directed graphs and 'G.neighbors' for undirected. +g_hamiltonian_path_ml :: L.MonadLogic m => G_NODE_SEL_F v e -> G.Gr v e -> G.Node -> m [G.Node] +g_hamiltonian_path_ml sel_f gr = + let n_deg = g_degree gr + recur r c = + if length r == n_deg - 1 + then return (c:r) + else do i <- ml_from_list (sel_f gr c) + L.guard (i `notElem` r) + recur (c:r) i + in recur [] + +-- > map (L.observeAll . ug_hamiltonian_path_ml_0) (g_partition gr) +ug_hamiltonian_path_ml_0 :: L.MonadLogic m => G.Gr v e -> m [G.Node] +ug_hamiltonian_path_ml_0 gr = g_hamiltonian_path_ml G.neighbors gr (G.nodes gr !! 0) + +-- * G (from edges) + +-- | Edge, no label. +type EDGE v = (v,v) + +-- | Graph as set of edges. +type GRAPH v = [EDGE v] + +-- | Edge, with label. +type EDGE_L v l = (EDGE v,l) + +-- | Graph as set of labeled edges. +type GRAPH_L v l = [EDGE_L v l] + +-- | Generate a graph given a set of labelled edges. +g_from_edges_l :: (Eq v,Ord v) => GRAPH_L v e -> G.Gr v e +g_from_edges_l e = + let n = nub (concatMap (\((lhs,rhs),_) -> [lhs,rhs]) e) + n_deg = length n + n_id = [0 .. n_deg - 1] + m = M.fromList (zip n n_id) + m_get k = M.findWithDefault (error "g_from_edges: m_get") k m + e' = map (\((lhs,rhs),label) -> (m_get lhs,m_get rhs,label)) e + in G.mkGraph (zip n_id n) e' + +-- | Variant that supplies '()' as the (constant) edge label. +-- +-- > let g = G.mkGraph [(0,'a'),(1,'b'),(2,'c')] [(0,1,()),(1,2,())] +-- > in g_from_edges_ul [('a','b'),('b','c')] == g +g_from_edges :: Ord v => GRAPH v -> G.Gr v () +g_from_edges = let f e = (e,()) in g_from_edges_l . map f + +-- * Edges + +-- | Label sequence of edges starting at one. +e_label_seq :: [EDGE v] -> [EDGE_L v Int] +e_label_seq = map (\(k,e) -> (e,k)) . zip [1..] + +-- | Normalised undirected labeled edge (ie. order nodes). +e_normalise_l :: Ord v => EDGE_L v l -> EDGE_L v l +e_normalise_l ((p,q),r) = ((min p q,max p q),r) + +-- | Collate labels for edges that are otherwise equal. +e_collate_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]] +e_collate_l = T.collate + +-- | 'e_collate_l' of 'e_normalise_l'. +e_collate_normalised_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]] +e_collate_normalised_l = e_collate_l . map e_normalise_l + +-- | Apply predicate to universe of possible edges. +e_univ_select_edges :: (t -> t -> Bool) -> [t] -> [EDGE t] +e_univ_select_edges f l = [(p,q) | p <- l, q <- l, f p q] + +-- | Consider only edges (p,q) where p < q. +e_univ_select_u_edges :: Ord t => (t -> t -> Bool) -> [t] -> [EDGE t] +e_univ_select_u_edges f = let g p q = p < q && f p q in e_univ_select_edges g + +-- | Sequence of connected vertices to edges. +-- +-- > e_path_to_edges "abcd" == [('a','b'),('b','c'),('c','d')] +e_path_to_edges :: [t] -> [EDGE t] +e_path_to_edges = T.adj2 1 + +-- | Undirected edge equality. +e_undirected_eq :: Eq t => EDGE t -> EDGE t -> Bool +e_undirected_eq (a,b) (c,d) = (a == c && b == d) || (a == d && b == c) + +elem_by :: (p -> q -> Bool) -> p -> [q] -> Bool +elem_by f = any . f + +-- | Is the sequence of vertices a path at the graph, ie. are all +-- adjacencies in the sequence edges. +e_is_path :: Eq t => GRAPH t -> [t] -> Bool +e_is_path e sq = + case sq of + p:q:sq' -> elem_by e_undirected_eq (p,q) e && e_is_path e (q:sq') + _ -> True diff --git a/Music/Theory/Graph/Johnson_2014.hs b/Music/Theory/Graph/Johnson_2014.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Johnson_2014.hs @@ -0,0 +1,290 @@ +-- | Tom Johnson. /Other Harmony: Beyond Tonal and Atonal/. Editions 75, 2014. +module Music.Theory.Graph.Johnson_2014 where + +import Control.Monad {- base -} +import Data.List {- base -} +import qualified Data.Map as M {- containers -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Combinations as T {- hmt -} +import qualified Music.Theory.Graph.Dot as T {- hmt -} +import qualified Music.Theory.Graph.FGL as T {- hmt -} +import qualified Music.Theory.Key as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuning.Euler as T {- hmt -} +import qualified Music.Theory.Z.SRO as T {- hmt -} + +-- * Common + +type Z12 = Int + +mod12 :: Integral a => a -> a +mod12 n = n `mod` 12 + +dif :: Num a => (a, a) -> a +dif = uncurry (-) + +absdif :: Num a => (a, a) -> a +absdif = abs . dif + +-- | interval (0,11) to interval class (0,6) +i_to_ic :: (Num a, Ord a) => a -> a +i_to_ic n = if n > 6 then 12 - n else n + +p2_and :: (t -> u -> Bool) -> (t -> u -> Bool) -> t -> u -> Bool +p2_and p q i j = p i j && q i j + +-- | degree of intersection +doi :: Eq t => [t] -> [t] -> Int +doi p = length . intersect p + +doi_of :: Eq t => Int -> [t] -> [t] -> Bool +doi_of n p = (==) n . doi p + +-- | The sum of the pointwise absolute difference. +loc_dif :: Num t => [t] -> [t] -> t +loc_dif p q = let f i j = abs (i - j) in sum (zipWith f p q) + +loc_dif_of :: (Eq t, Num t) => t -> [t] -> [t] -> Bool +loc_dif_of n p q = loc_dif p q == n + +loc_dif_in :: (Eq t, Num t) => [t] -> [t] -> [t] -> Bool +loc_dif_in n p q = loc_dif p q `elem` n + +-- | The number of places that are, pointwise, not equal. +-- +-- > loc_dif_n "test" "pest" == 1 +loc_dif_n :: (Eq t,Num i) => [t] -> [t] -> i +loc_dif_n p q = + let f i j = if i == j then 0 else 1 + in sum (zipWith f p q) + +loc_dif_n_of :: Eq t => Int -> [t] -> [t] -> Bool +loc_dif_n_of n p q = loc_dif_n p q == n + +-- > min_vl [6,11,13] [6,10,14] == 2 +min_vl :: (Num a,Ord a) => [a] -> [a] -> a +min_vl p q = + let f x = sum (map absdif (zip p x)) + in minimum (map f (permutations q)) + +min_vl_of :: (Num a, Ord a) => a -> [a] -> [a] -> Bool +min_vl_of n p q = min_vl p q == n + +min_vl_in :: (Num a, Ord a) => [a] -> [a] -> [a] -> Bool +min_vl_in n p q = min_vl p q `elem` n + +combinations2 :: Ord t => [t] -> [(t, t)] +combinations2 p = [(i,j) | i <- p, j <- p, i < j] + +set_pp :: Show t => [t] -> String +set_pp = intercalate "," . map show + +-- * Map + +m_get :: Ord k => M.Map k v -> k -> v +m_get m i = fromMaybe (error "get") (M.lookup i m) + +-- | degree of intersection +m_doi_of :: M.Map Int [Z12] -> Int -> Int -> Int -> Bool +m_doi_of m n p q = doi_of n (m_get m p) (m_get m q) + +-- * Graph + +gen_graph_ul :: Ord v => [T.DOT_ATTR] -> (v -> String) -> [T.EDGE v] -> [String] +gen_graph_ul opt pp es = T.g_to_udot opt (T.gr_pp_lift_node_f pp) (T.g_from_edges es) + +gen_graph_ul_ty :: Ord v => String -> (v -> String) -> [T.EDGE v] -> [String] +gen_graph_ul_ty ty = gen_graph_ul [("graph:layout",ty)] + +gen_flt_graph :: (Ord t, Show t) => [T.DOT_ATTR] -> ([t] -> [t] -> Bool) -> [[t]] -> [String] +gen_flt_graph o f p = gen_graph_ul o set_pp (T.e_univ_select_u_edges f p) + +-- * P.12 + +-- | +p12_euler_plane :: T.Euler_Plane Rational +p12_euler_plane = + let f = T.fold_ratio_to_octave_err + l1 = T.tun_seq 4 (3/2) (f (1 * 2/3 * 5/4)) + l2 = T.tun_seq 5 (3/2) (f (1 * 2/3 * 2/3)) + l3 = T.tun_seq 3 (3/2) (f (1 * 2/3 * 4/5)) + (c1,c2) = T.euler_align_rat (5/4,5/4) (l1,l2,l3) + in ([l1,l2,l3],c1 ++ c2) + +p12_euler_plane_gr :: [String] +p12_euler_plane_gr = T.euler_plane_to_dot_rat (0,True) p12_euler_plane + +-- * P.14 + +p14_edges :: [(T.Key,T.Key)] +p14_edges = + let univ = [0::Int .. 11] + trs n = map (mod12 . (+ n)) + e_par = zip univ univ + e_rel = zip univ (trs 9 univ) + e_med = zip univ (trs 4 univ) + del_par = [10] + del_rel = [5,6] + del_med = [2,5,8,11] + rem_set r = filter (\(lhs,_) -> lhs `notElem` r) + pc_to_key m pc = let Just (n,a) = T.pc_to_note_alteration_ks pc in (n,a,m) + e_lift (lhs,rhs) = (pc_to_key T.Major_Mode lhs,pc_to_key T.Minor_Mode rhs) + e_mod = concat [rem_set del_par e_par,rem_set del_rel e_rel,rem_set del_med e_med] + in map e_lift e_mod + +p14_gr :: [String] +p14_gr = + let opt = [("graph:start","168732")] + pp = T.gr_pp_lift_node_f T.key_lc_uc_pp + gr = T.g_from_edges p14_edges + in T.g_to_udot opt pp gr + +-- * P.31 + +p31_f_4_22 :: [Z12] +p31_f_4_22 = [0,2,4,7] + +p31_e_set :: [([Z12],[Z12])] +p31_e_set = T.e_univ_select_u_edges (doi_of 3) (map sort (T.z_sro_ti_related mod12 p31_f_4_22)) + +p31_gr :: [String] +p31_gr = gen_graph_ul [] set_pp p31_e_set + +-- * P.114 + +p114_f_3_7 :: [Z12] +p114_f_3_7 = [0,2,5] + +p114_mk_gr :: Double -> ([Z12] -> [Z12] -> Bool) -> [String] +p114_mk_gr el flt = + let o = [("node:shape","box") + ,("edge:len",show el)] + in gen_flt_graph o flt (map sort (T.z_sro_ti_related mod12 p114_f_3_7)) + +p114_gr_set :: [(String,[String])] +p114_gr_set = + [("p114.1.dot",p114_mk_gr 2.5 (doi_of 2)) + ,("p114.2.dot" + ,let o = [("edge:len","1.25")] + in gen_flt_graph o (loc_dif_of 1) (T.combinations 3 [1::Int .. 6])) + ,("p114.3.dot",p114_mk_gr 1.5 (loc_dif_n_of 1)) + ,("p114.4.dot",p114_mk_gr 1.5 (loc_dif_of 1)) + ,("p114.5.dot",p114_mk_gr 1.5 (loc_dif_of 2)) + ,("p114.6.dot",p114_mk_gr 1.5 (loc_dif_in [1,2])) + ,("p114.7.dot",p114_mk_gr 1.5 (loc_dif_in [1,2,3])) + ,("p114.8.dot",p114_mk_gr 1.5 (min_vl_in [1,2,3])) + ,("p114.9.dot",p114_mk_gr 2.0 (min_vl_in [1,2,3,4])) + ] + +-- * P.125 + +p125_gr :: [String] +p125_gr = + let t :: [[Int]] + t = [[p,q,r] | p <- [0 .. 11], q <- [0 .. 11], r <- [0 ..11], q > p, r > q] + c = T.collate (zip (map sum t) t) + with_h n = lookup n c + ch = fromJust (liftM2 (++) (with_h 15) (with_h 16)) + in gen_graph_ul [] set_pp (T.e_univ_select_u_edges (doi_of 2) ch) + +-- * P.131 + +p131_gr :: [String] +p131_gr = + let c = let u = [6::Int .. 14] + in [[p,q,r] | p <- u, q <- u, r <- u, q > p, r > q, p + q + r == 30] + in gen_graph_ul [] set_pp (T.e_univ_select_u_edges (min_vl_of 2) c) + +-- * P.148 + +p148_mk_gr :: ([Int] -> [Int] -> Bool) -> [String] +p148_mk_gr f = + let mid_set_pp :: [Int] -> String + mid_set_pp = concatMap show . take 3 . drop 1 + i_seq :: Num i => [[i]] + i_seq = permutations [1,2,3,4] + p_seq :: (Ord i,Num i) => [[i]] + p_seq = sort (map (T.dx_d 0) i_seq) + in gen_graph_ul [("edge:len","1.75")] mid_set_pp (T.e_univ_select_u_edges f p_seq) + +p148_gr_set :: [(String,[String])] +p148_gr_set = + [("p148.0.dot",p148_mk_gr (doi_of 4)) + ,("p148.1.dot",p148_mk_gr (min_vl_in [1])) + ,("p148.2.dot",p148_mk_gr (min_vl_in [1,2])) + ,("p148.3.dot",p148_mk_gr (p2_and (doi_of 4) (min_vl_in [1]))) + ,("p148.4.dot",p148_mk_gr (p2_and (doi_of 4) (min_vl_in [1,2]))) + ,("p148.5.dot",p148_mk_gr (loc_dif_n_of 1)) + ,("p148.6.dot",p148_mk_gr (loc_dif_of 1)) + ] + +-- * P.162 + +p162_gr :: [String] +p162_gr = + let n = [0::Int,1,2,3,4,5,6,7,8] + c = T.combinations 4 n + ch = filter ((== 1) . (`mod` 4) . sum) c + opt = [("graph:layout","neato") + ,("edge:len","1.75")] + in gen_graph_ul opt set_pp (T.e_univ_select_u_edges (doi_of 3) ch) + +-- * P.172 + +p172_nd_map :: M.Map Int [Z12] +p172_nd_map = + let nd_exp = map sort (T.z_sro_ti_related mod12 [0,1,3,7]) + in M.fromList (zip [0..] nd_exp) + +p172_set_pp :: Int -> String +p172_set_pp = set_pp . m_get p172_nd_map + +p172_gr_set :: [(String,[String])] +p172_gr_set = + [("p172.0.dot" + ,let nd_e_set = T.e_univ_select_u_edges (m_doi_of p172_nd_map 0) [0..23] + in gen_graph_ul_ty "circo" p172_set_pp nd_e_set) + ,("p172.1.dot" + ,let nd_e_set = concatMap T.e_path_to_edges + [[22,11,20,9,18,7,16,5,14,3,12,1,22] + ,[23,2,13,8,19,10,21,4,15,6,17,0,23]] + in gen_graph_ul_ty "circo" p172_set_pp nd_e_set)] + +-- * P.177 + +-- > map (partition_ic 4) p_set +-- > map (partition_ic 6) p_set +partition_ic :: (Num t, Ord t, Show t) => t -> [t] -> ([t], [t]) +partition_ic n p = + case find ((== n) . i_to_ic . absdif) (combinations2 p) of + Just (i,j) -> let q = sort [i,j] in (q,sort (p \\ q)) + Nothing -> error (show ("partition_ic",n,p)) + +p177_gr_set :: [(String,[String])] +p177_gr_set = + let p_set = concatMap (T.z_sro_ti_related mod12) [[0::Int,1,4,6],[0,1,3,7]] + in [("p177.0.dot",gen_graph_ul [] set_pp (map (partition_ic 4) p_set)) + ,("p177.1.dot",gen_graph_ul_ty "circo" set_pp (map (partition_ic 6) p_set)) + ,("p177.2.dot" + ,let gr_pp = T.gr_pp_lift_node_f set_pp + gr = T.g_from_edges (map (partition_ic 6) p_set) + in T.g_to_udot [("edge:len","1.5")] gr_pp gr)] + +-- * IO + +wr_graphs :: IO () +wr_graphs = do + let f (nm,gr) = writeFile ("/home/rohan/sw/hmt/data/dot/tj_oh_" ++ nm) (unlines gr) + f ("p012.dot",p12_euler_plane_gr) + f ("p014.dot",p14_gr) + f ("p031.dot",p31_gr) + mapM_ f p114_gr_set + f ("p125.dot",p125_gr) + f ("p131.dot",p131_gr) + mapM_ f p148_gr_set + f ("p162.dot",p162_gr) + mapM_ f p172_gr_set + mapM_ f p177_gr_set diff --git a/Music/Theory/IO.hs b/Music/Theory/IO.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/IO.hs @@ -0,0 +1,34 @@ +-- | "System.IO" related functions. +module Music.Theory.IO where + +import qualified Data.ByteString as B {- bytestring -} +import qualified Data.Text as T {- text -} +import qualified Data.Text.Encoding as T {- text -} +import qualified Data.Text.IO as T {- text -} +import qualified System.Directory as D {- directory -} + +-- | 'T.decodeUtf8' of 'B.readFile'. +read_file_utf8_text :: FilePath -> IO T.Text +read_file_utf8_text = fmap T.decodeUtf8 . B.readFile + +-- | Read (strictly) a UTF-8 encoded text file, implemented via "Data.Text". +read_file_utf8 :: FilePath -> IO String +read_file_utf8 = fmap T.unpack . read_file_utf8_text + +-- | 'read_file_utf8', or a default value if the file doesn't exist. +read_file_utf8_or :: String -> FilePath -> IO String +read_file_utf8_or def f = do + x <- D.doesFileExist f + if x then read_file_utf8 f else return def + +-- | Write UTF8 string as file, via "Data.Text". +write_file_utf8 :: FilePath -> String -> IO () +write_file_utf8 fn = B.writeFile fn . T.encodeUtf8 . T.pack + +-- | 'readFile' variant using 'Text' for @ISO 8859-1@ (Latin 1) encoding. +read_file_iso_8859_1 :: FilePath -> IO String +read_file_iso_8859_1 = fmap (T.unpack . T.decodeLatin1) . B.readFile + +-- | 'readFile' variant using 'Text' for local encoding. +read_file_locale :: FilePath -> IO String +read_file_locale = fmap T.unpack . T.readFile diff --git a/Music/Theory/Instrument/Names.hs b/Music/Theory/Instrument/Names.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Instrument/Names.hs @@ -0,0 +1,114 @@ +module Music.Theory.Instrument.Names where + +import Data.List.Split {- split -} + +-- (family,abbreviations,names,transpositions) +instrument_db' :: [(String,String,String,String)] +instrument_db' = + [("br","b.tbn","bass trombone","") + ,("br","b.tuba","bass tuba","") + ,("br","euph","euphonium","") + ,("br","hn","french horn","F") + ,("br","tbn;trm","trombone","") + ,("br","tb;tba","tuba","") + ,("br","tpt","trumpet","B♭") + ,("br","t.tbn","tenor trombone","") + ,("br","crt","cornet","") + ,("br","fgh;flhn","flugel horn","") + ,("br","p.tpt","piccolo trumpet","") + ,("el","cd","compact disc","") + ,("el","el;elec","electronics","") + ,("el","tp","tape","") + ,("el","om","ondes martenot","") + ,("kb","h;hrm","harmonium","") + ,("kb","e.pf","electric piano","") + ,("kb","p;pf;pno","piano;pianoforte","") + ,("kb","o;or;org","organ","") + ,("kb","kb;kbd","keyboard","") + ,("kb","cel","celeste","") + ,("kb","clvd","clavichord","") + ,("kb","hpd;hpcd","harpsichord","") + ,("kb","syn","synthesiser","") + ,("pc","bd","bass drum","") + ,("pc","btl","bottle","") + ,("pc","cast","castanets","") + ,("pc","cbell","cow-bell","") + ,("pc","bell","bell","chimes") + ,("pc","clv","clave","") + ,("pc","crot","crotales","") + ,("pc","cym","cymbals","") + ,("pc","dm","drum","") + ,("pc","gl;glsp","glockenspiel","") + ,("pc","mcas","maracas","") + ,("pc","met.bl","metal block","") + ,("pc","mr;mar","marimba","") + ,("pc","sd","side drum","") + ,("pc","sn.dm","snare drum","") + ,("pc","sus.cym","suspended cymbal","") + ,("pc","tamb","tambourine","") + ,("pc","tam","tam tam","") + ,("pc","t.bells","tubular bells","") + ,("pc","td","tenor drum","") + ,("pc","tri;tgl","triangle","") + ,("pc","tm;timp","timpani","") + ,("pc","tpl.bl","temple blocks","") + ,("pc","vb;vib","vibraphone","") + ,("pc","wdbl","wood block","") + ,("pc","xyl","xylophone","") + ,("str","va;vla","viola","") + ,("str","vc;vlc","cello;violoncello","") + ,("str","vn;vln","violin","") + ,("str","cb","contrabass","") + ,("str","db","double bass","") + ,("str","vda","viola d'amore","") + ,("str","b.gtr","bass guitar","") + ,("str","e.gtr","electric guitar","") + ,("str","gtr","guitar","") + ,("str","","lute","") + ,("str","zith","zither","") + ,("str","hp","harp","") + ,("str","dulc","dulcimer","") + ,("str","mand","mandolin","") + ,("vc","a;alt","alto","") + ,("vc","b;bass","bass","") + ,("vc","mz;mez","mezzo-soprano","") + ,("vc","n;nar","narrator","") + ,("vc","s;sop","soprano","") + ,("vc","t;tn","tenor","") + ,("vc","v;vc;voc","voice","") + ,("vc","ch","chorus","") + ,("vc","ctral","contralto","") + ,("vc","ctrbs","contrabass","") + ,("vc","bar","baritone","") + ,("vc","b.bar","bass baritone","") + ,("ww","b.cl","bass clarinet","") + ,("ww","cb.cl","contrabass clarinet","") + ,("ww","c;cl","clarinet","B♭") + ,("ww","a.fl","alto flute","G") + ,("ww","b.fl","bass flute","C") + ,("ww","bn;bsn","bassoon","") + ,("ww","f;fl","flute","") + ,("ww","hb;htb","hautbois","") + ,("ww","o;ob","oboe","") + ,("ww","p;picc","piccolo","") + ,("ww","ca","cor anglais","") + ,("ww","c.bn","contrabassoon","") + ,("ww","a.sax","alto saxophone","E♭") + ,("ww","b.sax","baritone saxophone","E♭") + ,("ww","b.ob","bass oboe","") + ,("ww","cfg","contrafagotto","") + ,("ww","eh;en.hn","english horn","") + ,("ww","fg","fagotto","") + ,("ww","rec","recorder","") + ,("ww","sax","saxophone","") + ,("ww","s.sax","soprano saxophone","B♭") + ,("ww","t.sax","tenor saxophone","B♭") + ,("ww","oca","ocarina","") + ] + +-- (family,[abbreviations],[names],[transpositions]) +instrument_db :: [(String,[String],[String],[String])] +instrument_db = + let sep = splitOn ";" + f (fm,ab,nm,tr) = (fm,sep ab,sep nm,sep tr) + in map f instrument_db' diff --git a/Music/Theory/Interval.hs b/Music/Theory/Interval.hs --- a/Music/Theory/Interval.hs +++ b/Music/Theory/Interval.hs @@ -4,8 +4,9 @@ import Data.List {- base -} import Data.Maybe {- base -} -import Music.Theory.Pitch -import Music.Theory.Pitch.Note +import qualified Music.Theory.Ord as T +import qualified Music.Theory.Pitch as T +import qualified Music.Theory.Pitch.Note as T -- | Interval type or degree. data Interval_T = Unison | Second | Third | Fourth @@ -24,13 +25,13 @@ data Interval = Interval {interval_type :: Interval_T ,interval_quality :: Interval_Q ,interval_direction :: Ordering - ,interval_octave :: Octave} + ,interval_octave :: T.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 :: T.Note_T -> 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 @@ -95,41 +96,17 @@ 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 :: T.Pitch -> T.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 + (T.Pitch n1 _ o1) = p1 + (T.Pitch n2 _ o2) = p2 + p1' = T.pitch_to_pc p1 + p2' = T.pitch_to_pc p2 st = (p2' - p1') `mod` 12 ty = interval_ty n1 n2 (Just qu) = interval_q ty (fromIntegral st) @@ -138,13 +115,11 @@ GT -> (interval p2 p1) { interval_direction = GT } _ -> Interval ty qu c (o2 - o1 + o_a) --- | Apply 'invert_ordering' to 'interval_direction' of 'Interval'. +-- | Apply 'T.ord_invert' 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 +invert_interval (Interval t qu d o) = Interval t qu (T.ord_invert d) o -- | The signed difference in semitones between two 'Interval_Q' -- values when applied to the same 'Interval_T'. Can this be written @@ -185,9 +160,9 @@ -- | 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 :: Interval -> T.Pitch -> T.Pitch pitch_transpose i ip = - let (Pitch p_n p_a p_o) = ip + let (T.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 @@ -199,10 +174,10 @@ else if p_n' < p_n && i_d == LT then 1 else 0 - ip' = Pitch p_n' p_a (p_o + i_o + oa) + ip' = T.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 + then (T.pitch_to_pc ip - T.pitch_to_pc ip') `mod` 12 + else (T.pitch_to_pc ip' - T.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' @@ -210,14 +185,14 @@ 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' } + in ip' {T.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 :: T.Pitch -> ([T.Pitch], [T.Pitch]) circle_of_fifths x = let p4 = Interval Fourth Perfect LT 0 p5 = Interval Fifth Perfect LT 0 @@ -228,7 +203,7 @@ -- displacement. -- -- > mapMaybe parse_interval_type (map show [1 .. 15]) -parse_interval_type :: String -> Maybe (Interval_T,Octave) +parse_interval_type :: String -> Maybe (Interval_T,T.Octave) parse_interval_type n = case reads n of [(n',[])] -> if n' == 0 @@ -249,7 +224,7 @@ -- '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 :: (Interval_T,T.Octave) -> Int interval_type_degree (t,o) = fromEnum t + 1 + (fromIntegral o * 7) -- | Inverse of 'parse_interval_quality. @@ -282,6 +257,10 @@ '+':q:n -> f q n q:n -> f q n _ -> Nothing + +-- | 'error' variant. +parse_interval_err :: String -> Interval +parse_interval_err = fromMaybe (error "parse_interval") . parse_interval -- | Pretty printer for intervals, inverse of 'parse_interval'. interval_pp :: Interval -> String diff --git a/Music/Theory/Interval/Barlow_1987.hs b/Music/Theory/Interval/Barlow_1987.hs --- a/Music/Theory/Interval/Barlow_1987.hs +++ b/Music/Theory/Interval/Barlow_1987.hs @@ -5,12 +5,13 @@ 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 +import qualified Data.Numbers.Primes as P {- primes -} +import qualified Music.Theory.Tuning as T {- hmt -} + -- | 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] @@ -22,22 +23,26 @@ -- | Generate list of factors of /n/ from /x/. -- --- > factor primes 315 == [3,3,5,7] +-- > factor P.primes 315 == [3,3,5,7] +-- > P.primeFactors 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 + i:x' -> if n < i + then [] -- ie. prime factors of 1... + else 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] +-- > map prime_factors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]] +-- > map P.primeFactors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]] prime_factors :: Integral a => a -> [a] -prime_factors = factor primes +prime_factors = factor P.primes -- | Collect number of occurences of each element of a sorted list. -- @@ -49,11 +54,11 @@ e:_ -> (e,genericLength x) in map f . group --- | 'multiplicities' '.' 'prime_factors'. +-- | 'multiplicities' '.' 'P.primeFactors'. -- -- > prime_factors_m 315 == [(3,2),(5,1),(7,1)] prime_factors_m :: Integral a => a -> [(a,a)] -prime_factors_m = multiplicities . prime_factors +prime_factors_m = multiplicities . P.primeFactors -- | Merging function for 'rational_prime_factors_m'. merge :: (Ord a,Num b,Eq b) => [(a,b)] -> [(a,b)] -> [(a,b)] @@ -91,10 +96,11 @@ -- up to the /n/th prime. -- -- > rational_prime_factors_t 6 (12,7) == [2,1,0,-1,0,0] +-- > rational_prime_factors_t 6 (32,9) == [5,-2,0,0,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) + in map (\i -> fromMaybe 0 (lookup i r)) (take n P.primes) -- | Compute the disharmonicity of the interval /(p,q)/ using the -- prime valuation function /pv/. @@ -120,7 +126,7 @@ to_rational = uncurry (%) -- | Make 'numerator' 'denominator' pair of /n/. -from_rational :: Integral t => Ratio t -> (t, t) +from_rational :: Ratio t -> (t, t) from_rational n = (numerator n,denominator n) -- | Set of 1. interval size (cents), 2. intervals as product of @@ -130,13 +136,14 @@ -- | Table 2 (p.45) -- -- > length (table_2 0.06) == 24 +-- > length (table_2 0.04) == 66 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) + k (i,j) = (T.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. diff --git a/Music/Theory/Key.hs b/Music/Theory/Key.hs --- a/Music/Theory/Key.hs +++ b/Music/Theory/Key.hs @@ -1,33 +1,205 @@ -- | Common music keys. module Music.Theory.Key where +import Control.Monad {- base -} +import Data.Char {- base -} import Data.List {- base -} +import Data.Maybe {- base -} -import Music.Theory.Pitch -import Music.Theory.Pitch.Name -import Music.Theory.Pitch.Note -import Music.Theory.Interval +import qualified Music.Theory.List as T +import qualified Music.Theory.Pitch as T +import qualified Music.Theory.Pitch.Name as T +import qualified Music.Theory.Pitch.Note as T +import qualified Music.Theory.Interval as T -- | 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) +-- | Pretty printer for 'Mode_T'. +mode_pp :: Mode_T -> String +mode_pp m = + case m of + Minor_Mode -> "Minor" + Major_Mode -> "Major" +-- | Lower-cased 'mode_pp'. +mode_identifier_pp :: Mode_T -> String +mode_identifier_pp = map toLower . mode_pp + +-- | There are two modes, given one return the other. +mode_parallel :: Mode_T -> Mode_T +mode_parallel m = if m == Minor_Mode then Major_Mode else Minor_Mode + +mode_pc_seq :: Num t => Mode_T -> [t] +mode_pc_seq md = + case md of + Major_Mode -> [0,2,4,5,7,9,11] + Minor_Mode -> [0,2,3,5,7,8,10] + +-- | A common music notation key is a 'Note_T', 'Alteration_T', 'Mode_T' triple. +type Key = (T.Note_T,T.Alteration_T,Mode_T) + +-- | 'Mode_T' of 'Key'. +key_mode :: Key -> Mode_T +key_mode (_,_,m) = m + +-- | Enumeration of 42 CMN keys. +-- +-- > length key_sequence_42 == 7 * 3 * 2 +key_sequence_42 :: [Key] +key_sequence_42 = + let a_seq = [T.Flat,T.Natural,T.Sharp] + m_seq = [Major_Mode,Minor_Mode] + in [(n,a,m) | n <- T.note_seq,a <- a_seq,m <- m_seq] + +-- | Subset of 'key_sequence' not including very eccentric keys (where +-- there are more than 7 alterations). +-- +-- > length key_sequence_30 == 30 +key_sequence_30 :: [Key] +key_sequence_30 = filter (\k -> maybe False ((< 8) . abs) (key_fifths k)) key_sequence_42 + +-- | Parallel key, ie. 'mode_parallel' of 'Key'. +key_parallel :: Key -> Key +key_parallel (n,a,m) = (n,a,mode_parallel m) + +-- | Transposition of 'Key'. +key_transpose :: Key -> Int -> Key +key_transpose (n,a,m) x = + let Just pc = T.note_alteration_to_pc (n,a) + Just (n',a') = T.pc_to_note_alteration_ks ((pc + x) `mod` 12) + in (n',a',m) + +-- | Relative key (ie. 'mode_parallel' with the same number of and type of alterations. +-- +-- > let k = [(T.C,T.Natural,Major_Mode),(T.E,T.Natural,Minor_Mode)] +-- > in map (key_lc_uc_pp . key_relative) k == ["a♮","G♮"] +key_relative :: Key -> Key +key_relative k = + case key_mode k of + Major_Mode -> key_parallel (key_transpose k 9) + Minor_Mode -> key_parallel (key_transpose k 3) + +-- | Mediant minor of major key. +-- +-- > key_mediant (T.C,T.Natural,Major_Mode) == Just (T.E,T.Natural,Minor_Mode) +key_mediant :: Key -> Maybe Key +key_mediant k = + case key_mode k of + Major_Mode -> Just (key_parallel (key_transpose k 4)) + _ -> Nothing + +-- > fmap key_pc_set (key_lc_uc_parse "E") +key_pc_set :: Integral i => Key -> [i] +key_pc_set (n,a,md) = + let pc0 = T.note_to_pc n + T.alteration_to_diff_err a + in sort (map ((`mod` 12) . (+ pc0)) (mode_pc_seq md)) + +-- | Pretty-printer where 'Minor_Mode' is written in lower case (lc) and +-- alteration symbol is shown using indicated function. +key_lc_pp :: (T.Alteration_T -> String) -> Key -> String +key_lc_pp a_pp (n,a,m) = + let c = T.note_pp n + c' = if m == Minor_Mode then toLower c else c + in c' : a_pp a + +-- | 'key_lc_pp' with unicode (uc) alteration. +-- +-- > map key_lc_uc_pp [(C,Sharp,Minor_Mode),(E,Flat,Major_Mode)] == ["c♯","E♭"] +key_lc_uc_pp :: Key -> String +key_lc_uc_pp = key_lc_pp (return . T.alteration_symbol) + +-- | 'key_lc_pp' with ISO alteration. +key_lc_iso_pp :: Key -> String +key_lc_iso_pp = key_lc_pp T.alteration_iso + +-- | 'key_lc_pp' with tonh alteration. +-- +-- > map key_lc_tonh_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)] +key_lc_tonh_pp :: Key -> String +key_lc_tonh_pp = key_lc_pp T.alteration_tonh + +-- > map key_identifier_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)] +key_identifier_pp :: (Show a, Show a1) => (a, a1, Mode_T) -> [Char] +key_identifier_pp (n,a,m) = map toLower (intercalate "_" [show n,show a,mode_pp m]) + +-- > import Data.Maybe +-- > mapMaybe note_char_to_key "CdEfGaB" +note_char_to_key :: Char -> Maybe Key +note_char_to_key c = + let m = if isUpper c then Major_Mode else Minor_Mode + in fmap (\n -> (n,T.Natural,m)) (T.parse_note_t True c) + +-- | Parse 'Key' from /lc-uc/ string. +-- +-- > import Data.Maybe +-- +-- > let k = mapMaybe key_lc_uc_parse ["c","E","f♯","ab","G#"] +-- > in map key_lc_uc_pp k == ["c♮","E♮","f♯","a♭","G♯"] +key_lc_uc_parse :: String -> Maybe Key +key_lc_uc_parse k = + let with_k a (n,_,m) = (n,a,m) + with_a n a = fmap (with_k a) (note_char_to_key n) + in case k of + [c] -> note_char_to_key c + [n,a] -> join (fmap (with_a n) (T.symbol_to_alteration_iso a)) + _ -> Nothing + -- | 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 (T.A,T.Natural,Minor_Mode) == Just 0 +-- > key_fifths (T.A,T.Natural,Major_Mode) == Just 3 +-- > key_fifths (T.C,T.Natural,Minor_Mode) == Just (-3) +-- > key_fifths (T.B,T.Sharp,Minor_Mode) == Just 9 +-- > key_fifths (T.E,T.Sharp,Major_Mode) == Just 11 +-- > key_fifths (T.B,T.Sharp,Major_Mode) == Nothing +-- +-- > zip (map key_lc_iso_pp key_sequence_42) (map key_fifths key_sequence_42) +key_fifths :: Key -> Maybe 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 + let cf x = let (p,q) = T.circle_of_fifths x in p ++ q + eq (T.Pitch n' a' _) = n == n' && a == a' + ix = case m of + Major_Mode -> findIndex eq (cf T.c4) + Minor_Mode -> findIndex eq (cf T.a4) + in fmap (\i -> if i < 13 then negate i else i - 12) ix + +-- | Table mapping 'Key' to 'key_fifths' value. +key_fifths_tbl :: [(Key,Int)] +key_fifths_tbl = + let f (k,n) = maybe Nothing (\n' -> Just (k,n')) n + in mapMaybe f (zip key_sequence_42 (map key_fifths key_sequence_42)) + +-- | Lookup 'key_fifths' value in 'key_fifths_tbl'. +-- +-- > let a = [0,1,-1,2,-2,3,-3,4,-4,5,-5] +-- > let f md = map key_lc_iso_pp . mapMaybe (fifths_to_key md) +-- > f Minor_Mode a +-- > f Major_Mode a +fifths_to_key :: Mode_T -> Int -> Maybe Key +fifths_to_key md n = + let eq_f = (\((_,_,md'),n') -> md == md' && n == n') + in fmap fst (find eq_f key_fifths_tbl) + +-- | Given sorted pitch-class set, find simplest implied key in given mode. +-- +-- > mapMaybe (implied_key Major_Mode) [[0,2,4],[1,3],[4,10],[3,9],[8,9]] +-- > map (implied_key Major_Mode) [[0,1,2],[0,1,3,4]] == [Nothing,Nothing] +implied_key :: Integral i => Mode_T -> [i] -> Maybe Key +implied_key md pc_set = + let a_seq = [0,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6] + key_seq = mapMaybe (fifths_to_key md) a_seq + in find (\k -> pc_set `T.is_subset` key_pc_set k) key_seq + +-- | 'key_fifths' of 'implied_key'. +implied_fifths :: Integral i => Mode_T -> [i] -> Maybe Int +implied_fifths md = join . fmap key_fifths . implied_key md + +implied_key_err :: Integral i => Mode_T -> [i] -> Key +implied_key_err md = fromMaybe (error "implied_key") . implied_key md + +implied_fifths_err :: Integral i => Mode_T -> [i] -> Int +implied_fifths_err md = fromMaybe (error "implied_fifths") . key_fifths . implied_key_err md diff --git a/Music/Theory/List.hs b/Music/Theory/List.hs --- a/Music/Theory/List.hs +++ b/Music/Theory/List.hs @@ -1,24 +1,95 @@ -- | List functions. module Music.Theory.List where +import Data.Either {- base -} import Data.Function {- base -} +import qualified Data.IntMap as Map {- containers -} import Data.List {- base -} -import qualified Data.List.Ordered as O {- data-ordlist -} -import Data.List.Split {- split -} import Data.Maybe {- base -} +import Data.Tree {- containers -} +import qualified Data.Traversable as T {- base -} +import qualified Data.List.Ordered as O {- data-ordlist -} +import qualified Data.List.Split as S {- split -} +import qualified Data.List.Split.Internals as S {- split -} + +import qualified Control.Monad.Logic as L {- logict -} + +-- | Data.Vector.slice, ie. starting index (zero-indexed) and number of elements. +-- +-- > slice 4 5 [1..] == [5,6,7,8,9] +slice :: Int -> Int -> [a] -> [a] +slice i n = take n . drop i + +-- | Variant of slice with start and end indices (zero-indexed). +-- +-- > section 4 8 [1..] == [5,6,7,8,9] +section :: Int -> Int -> [a] -> [a] +section l r = take (r - l + 1) . drop l + -- | 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] +unbracket' :: [a] -> (Maybe a,[a],Maybe a) +unbracket' x = + case x of + [] -> (Nothing,[],Nothing) + l:x' -> let (m,r) = separate_last' x' in (Just l,m,r) + +-- | The first & middle & last elements of a list. +-- +-- > unbracket "[12]" == Just ('[',"12",']') +unbracket :: [t] -> Maybe (t,[t],t) +unbracket x = + case unbracket' x of + (Just l,m,Just r) -> Just (l,m,r) + _ -> Nothing + +unbracket_err :: [t] -> (t,[t],t) +unbracket_err = fromMaybe (error "unbracket") . unbracket + -- | 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 +-- * Split + +-- | Relative of 'splitOn', but only makes first separation. +-- +-- > splitOn "//" "lhs//rhs//rem" == ["lhs","rhs","rem"] +-- > separate_at "//" "lhs//rhs//rem" == Just ("lhs","rhs//rem") +separate_at :: Eq a => [a] -> [a] -> Maybe ([a],[a]) +separate_at x = + let n = length x + f lhs rhs = + if null rhs + then Nothing + else if x == take n rhs + then Just (reverse lhs,drop n rhs) + else f (head rhs : lhs) (tail rhs) + in f [] + +-- | 'Splitter' comparing single element. +on_elem :: Eq a => a -> S.Splitter a +on_elem e = S.defaultSplitter { S.delimiter = S.Delimiter [(==) e] } + +-- | Split before the indicated element. +-- +-- > split_before 'x' "axbcxdefx" == ["a","xbc","xdef","x"] +-- > split_before 'x' "xa" == ["","xa"] +-- +-- > map (flip split_before "abcde") "ae_" == [["","abcde"],["abcd","e"],["abcde"]] +-- > map (flip break "abcde" . (==)) "ae_" == [("","abcde"),("abcd","e"),("abcde","")] +split_before :: Eq a => a -> [a] -> [[a]] +split_before = S.split . S.keepDelimsL . on_elem + +-- * Rotate + -- | Generic form of 'rotate_left'. genericRotate_left :: Integral i => i -> [a] -> [a] genericRotate_left n = @@ -63,6 +134,42 @@ rotations :: [a] -> [[a]] rotations p = map (`rotate_left` p) [0 .. length p - 1] +-- | Rotate list so that is starts at indicated element. +-- +-- > rotate_starting_from 'c' "abcde" == Just "cdeab" +-- > rotate_starting_from '_' "abc" == Nothing +rotate_starting_from :: Eq a => a -> [a] -> Maybe [a] +rotate_starting_from x l = + case break (== x) l of + (_,[]) -> Nothing + (lhs,rhs) -> Just (rhs ++ lhs) + +-- | Erroring variant. +rotate_starting_from_err :: Eq a => a -> [a] -> [a] +rotate_starting_from_err x = + fromMaybe (error "rotate_starting_from: non-element") . + rotate_starting_from x + +-- | Sequence of /n/ adjacent elements, moving forward by /k/ places. +-- The last element may have fewer than /n/ places, but will reach the +-- end of the input sequence. +-- +-- > adj 3 2 "adjacent" == ["adj","jac","cen","nt"] +adj :: Int -> Int -> [a] -> [[a]] +adj n k l = + case take n l of + [] -> [] + r -> r : adj n k (drop k l) + +-- | Variant of 'adj' where the last element has /n/ places but may +-- not reach the end of the input sequence. +-- +-- > adj' 3 2 "adjacent" == ["adj","jac","cen"] +adj' :: Int -> Int -> [a] -> [[a]] +adj' n k l = + let r = take n l + in if length r == n then r : adj' n k (drop k l) else [] + -- | Generic form of 'adj2'. genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)] genericAdj2 n l = @@ -73,6 +180,7 @@ -- | Adjacent elements of list, at indicated distance, as pairs. -- -- > adj2 1 [1..5] == [(1,2),(2,3),(3,4),(4,5)] +-- > let l = [1..5] in zip l (tail l) == adj2 1 l -- > adj2 2 [1..4] == [(1,2),(3,4)] -- > adj2 3 [1..5] == [(1,2),(4,5)] adj2 :: Int -> [t] -> [(t,t)] @@ -98,11 +206,55 @@ -- > interleave [1..3] [4..6] == [1,4,2,5,3,6] -- > interleave ".+-" "abc" == ".a+b-c" -- > interleave [1..3] [] == [] -interleave :: [b] -> [b] -> [b] +interleave :: [a] -> [a] -> [a] interleave p q = let u (i,j) = [i,j] in concatMap u (zip p q) +-- | Interleave list of lists. Allows lists to be of non-equal lenghts. +-- +-- > interleave_set ["abcd","efgh","ijkl"] == "aeibfjcgkdhl" +-- > interleave_set ["abc","defg","hijkl"] == "adhbeicfjgkl" +interleave_set :: [[a]] -> [a] +interleave_set = concat . transpose + +{- +import Safe {- safe -} + +interleave_set l = + case mapMaybe headMay l of + [] -> [] + r -> r ++ interleave_set (mapMaybe tailMay l) +-} + +-- | De-interleave /n/ lists. +-- +-- > deinterleave 2 ".a+b-c" == [".+-","abc"] +-- > deinterleave 3 "aeibfjcgkdhl" == ["abcd","efgh","ijkl"] +deinterleave :: Int -> [a] -> [[a]] +deinterleave n = transpose . S.chunksOf n + +-- | Special case for two-part deinterleaving. +-- +-- > deinterleave2 ".a+b-c" == (".+-","abc") +deinterleave2 :: [t] -> ([t], [t]) +deinterleave2 = + let f l = + case l of + p:q:l' -> (p,q) : f l' + _ -> [] + in unzip . f + +{- +deinterleave2 = + let f p q l = + case l of + [] -> (reverse p,reverse q) + [a] -> (reverse (a:p),reverse q) + a:b:l' -> rec (a:p) (b:q) l' + in f [] [] +-} + -- | Variant that continues with the longer input. -- -- > interleave_continue ".+-" "abc" == ".a+b-c" @@ -121,15 +273,31 @@ interleave_rotations :: Int -> Int -> [b] -> [b] interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s) +generic_histogram :: (Ord a,Integral i) => [a] -> [(a,i)] +generic_histogram x = + let g = group (sort x) + in zip (map head g) (map genericLength g) + +histogram_by :: Ord a => (a -> a -> Bool) -> [a] -> [(a,Int)] +histogram_by f x = + let g = groupBy f (sort x) + in zip (map head g) (map length g) + -- | 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 +-- > map histogram ["","hohoh"] == [[],[('h',3),('o',2)]] +histogram :: Ord a => [a] -> [(a,Int)] +histogram = histogram_by (==) +duplicates_by :: Ord a => (a -> a -> Bool) -> [a] -> [a] +duplicates_by f = map fst . filter (\(_,n) -> n > 1) . histogram_by f + +-- | Elements that appear more than once in the input. +-- +-- > map duplicates ["duplicates","redundant"] == ["","dn"] +duplicates :: Ord a => [a] -> [a] +duplicates = duplicates_by (==) + -- | List segments of length /i/ at distance /j/. -- -- > segments 2 1 [1..5] == [[1,2],[2,3],[3,4],[4,5]] @@ -164,27 +332,79 @@ -- > 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 +cycles n = transpose . S.chunksOf n +-- | Variant of 'filter' that has a predicate to halt processing, +-- ie. 'filter' of 'takeWhile'. +-- +-- > filter_halt (even . fst) ((< 5) . snd) (zip [1..] [0..]) +filter_halt :: (a -> Bool) -> (a -> Bool) -> [a] -> [a] +filter_halt sel end = filter sel . takeWhile end + +-- | Replace all /p/ with /q/ in /s/. +-- +-- > replace "_x_" "-X-" "an _x_ string" == "an -X- string" +-- > replace "ab" "cd" "ab ab cd ab" == "cd cd cd cd" +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace p q s = + let n = length p + in case s of + [] -> [] + c:s' -> if p `isPrefixOf` s + then q ++ replace p q (drop n s) + else c : replace p q s' + +-- | Replace the /i/th value at /ns/ with /x/. +-- +-- > replace_at "test" 2 'n' == "tent" +replace_at :: Integral i => [a] -> i -> a -> [a] +replace_at ns i x = + let f j y = if i == j then x else y + in zipWith f [0..] ns + -- * Association lists --- | Given accesors for /key/ and /value/ collate input. +-- | Equivalent to 'groupBy' '==' 'on' /f/. -- --- > 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 r = [[(1,'a'),(1,'b')],[(2,'c')],[(3,'d'),(3,'e')],[(4,'f')]] +-- > in group_on fst (zip [1,1,2,3,3,4] "abcdef") == r +group_on :: Eq x => (a -> x) -> [a] -> [[a]] +group_on f = map (map snd) . groupBy ((==) `on` fst) . map (\x -> (f x,x)) + +-- | Given accesors for /key/ and /value/ collate adjacent values. +collate_on_adjacent :: (Eq k,Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])] +collate_on_adjacent f g = let h l = case l of - [] -> error "collate_on" + [] -> error "collate_on_adjacent" l0:_ -> (f l0,map g l) - in map h . groupBy ((==) `on` f) . sortBy (compare `on` f) + in map h . group_on f +-- | 'collate_on_adjacent' of 'fst' and 'snd'. +-- +-- > collate_adjacent (zip "TDD" "xyz") == [('T',"x"),('D',"yz")] +collate_adjacent :: Ord a => [(a,b)] -> [(a,[b])] +collate_adjacent = collate_on_adjacent fst snd + +-- | 'sortOn' prior to 'collate_on_adjacent'. +-- +-- > let r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")] +-- > in collate_on fst snd (zip "ABCBCD" "abcdef") == r +collate_on :: Ord k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])] +collate_on f g = collate_on_adjacent f g . sortOn f + -- | 'collate_on' of 'fst' and 'snd'. -- +-- > collate (zip "TDD" "xyz") == [('D',"yz"),('T',"x")] -- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")] collate :: Ord a => [(a,b)] -> [(a,[b])] collate = collate_on fst snd +-- | Reverse of 'collate', inverse if order is not considered. +-- +-- > uncollate [(1,"ac"),(2,"b")] == zip [1,1,2] "acb" +uncollate :: [(k,[v])] -> [(k,v)] +uncollate = concatMap (\(k,v) -> zip (repeat k) v) + -- | Make /assoc/ list with given /key/. -- -- > with_key 'a' [1..3] == [('a',1),('a',2),('a',3)] @@ -208,12 +428,18 @@ e:r -> (e,reverse r) _ -> error "dx_d'" --- | Integrate, ie. pitch class segment to interval sequence. +-- | Apply flip of /f/ between elements of /l/. -- +-- > d_dx_by (,) "abcd" == [('b','a'),('c','b'),('d','c')] +d_dx_by :: (t -> t -> u) -> [t] -> [u] +d_dx_by f l = if null l then [] else zipWith f (tail l) l + +-- | Integrate, 'd_dx_by' '-', 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 +d_dx = d_dx_by (-) -- | Elements of /p/ not in /q/. -- @@ -250,18 +476,80 @@ [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 = +-- | Lookup that errors and prints message. +lookup_err_msg :: (Eq k,Show k) => String -> k -> [(k,v)] -> v +lookup_err_msg err k = fromMaybe (error (err ++ ": " ++ show k)) . lookup k + +-- | Error variant. +lookup_err :: Eq k => k -> [(k,v)] -> v +lookup_err n = fromMaybe (error "lookup") . lookup n + +-- | 'lookup' variant with default value. +lookup_def :: Eq k => k -> v -> [(k,v)] -> v +lookup_def k d = fromMaybe d . lookup k + +-- | Reverse lookup. +-- +-- > reverse_lookup 'c' [] == Nothing +-- > reverse_lookup 'c' (zip [0..4] ['a'..]) == Just 2 +reverse_lookup :: Eq b => b -> [(a,b)] -> Maybe a +reverse_lookup k = fmap fst . find ((== k) . snd) + +{- +reverse_lookup :: Eq b => b -> [(a,b)] -> Maybe a +reverse_lookup key ls = + case ls of + [] -> Nothing + (x,y):ls' -> if key == y then Just x else reverse_lookup key ls' +-} + + +-- | Basis of 'find_bounds_scl', indicates if /x/ is to the left or +-- right of the list, and it to the right whether equal or not. +-- 'Right' values will be correct if the list is not ascending, +-- however 'Left' values only make sense for ascending ranges. +-- +-- > map (find_bounds' compare [(0,1),(1,2)]) [-1,0,1,2,3] +find_bounds' :: (t -> s -> Ordering) -> [(t,t)] -> s -> Either ((t,t),Ordering) (t,t) +find_bounds' 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 + [] -> error "find_bounds': nil" + [(p,q)] -> if g (p,q) then Right (p,q) else Left ((p,q),f q x) + (p,q):l' -> if f p x == GT + then Left ((p,q),GT) + else if g (p,q) then Right (p,q) else find_bounds' f l' x +decide_nearest' :: Ord o => (p -> o) -> (p,p) -> p +decide_nearest' f (p,q) = if f p < f q then p else q + +-- | Decide if value is nearer the left or right value of a range. +decide_nearest :: (Num o,Ord o) => o -> (o, o) -> o +decide_nearest x = decide_nearest' (abs . (x -)) + +-- | Find the number that is nearest the requested value in an +-- ascending list of numbers. +-- +-- > map (find_nearest_err [0,3.5,4,7]) [-1,1,3,5,7,9] == [0,0,3.5,4,7,7] +find_nearest_err :: (Num n,Ord n) => [n] -> n -> n +find_nearest_err l x = + case find_bounds' compare (adj2 1 l) x of + Left ((p,_),GT) -> p + Left ((_,q),_) -> q + Right (p,q) -> decide_nearest x (p,q) + +find_nearest :: (Num n,Ord n) => [n] -> n -> Maybe n +find_nearest l x = if null l then Nothing else Just (find_nearest_err l x) + +-- | 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_scl :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t) +find_bounds_scl scl f l x = + case find_bounds' f l x of + Right r -> Just r + Left (r,EQ) -> if scl then Just r else Nothing + _ -> Nothing + -- | Find adjacent elements of list that bound element under given -- comparator. -- @@ -269,8 +557,18 @@ -- > ;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) +find_bounds scl f l = find_bounds_scl scl f (adj2 1 l) +-- | Special case of 'dropRight'. +-- +-- > map drop_last ["","?","remove"] == ["","","remov"] +drop_last :: [t] -> [t] +drop_last l = + case l of + [] -> [] + [_] -> [] + e:l' -> e : drop_last l' + -- | Variant of 'drop' from right of list. -- -- > dropRight 1 [1..9] == [1..8] @@ -283,6 +581,18 @@ dropWhileRight :: (a -> Bool) -> [a] -> [a] dropWhileRight p = reverse . dropWhile p . reverse +-- | 'take' from right. +-- +-- > take_right 3 "taking" == "ing" +take_right :: Int -> [a] -> [a] +take_right n = reverse . take n . reverse + +-- | 'takeWhile' from right. +-- +-- > take_while_right Data.Char.isDigit "A440" == "440" +take_while_right :: (a -> Bool) -> [a] -> [a] +take_while_right p = reverse . takeWhile p . reverse + -- | Apply /f/ at first element, and /g/ at all other elements. -- -- > at_head negate id [1..5] == [-1,2,3,4,5] @@ -302,13 +612,20 @@ [i] -> [g i] i:x' -> f i : at_last f g x' --- | Separate list into an initial list and a last element tuple. +-- | Separate list into an initial list and perhaps the last element tuple. -- +-- > separate_last' [] == ([],Nothing) +separate_last' :: [a] -> ([a],Maybe a) +separate_last' x = + case reverse x of + [] -> ([],Nothing) + e:x' -> (reverse x',Just e) + +-- | Error on null input. +-- -- > separate_last [1..5] == ([1..4],5) separate_last :: [a] -> ([a],a) -separate_last x = - let e:x' = reverse x - in (reverse x',e) +separate_last = fmap (fromMaybe (error "separate_last")) . separate_last' -- | Replace directly repeated elements with 'Nothing'. -- @@ -320,6 +637,22 @@ e:l' -> Just e : map (const Nothing) l' in concatMap f . group +-- | 'zipWith' of list and it's own tail. +-- +-- > zip_with_adj (,) "abcde" == [('a','b'),('b','c'),('c','d'),('d','e')] +zip_with_adj :: (a -> a -> b) -> [a] -> [b] +zip_with_adj f xs = zipWith f xs (tail xs) + +-- | Type-specialised 'zip_with_adj'. +compare_adjacent_by :: (a -> a -> Ordering) -> [a] -> [Ordering] +compare_adjacent_by = zip_with_adj + +-- | 'compare_adjacent_by' of 'compare'. +-- +-- > compare_adjacent [0,1,3,2] == [LT,LT,GT] +compare_adjacent :: Ord a => [a] -> [Ordering] +compare_adjacent = compare_adjacent_by compare + -- | '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. @@ -337,23 +670,42 @@ then (x:r0) : r' else [x] : r +-- | Reduce sequences of consecutive values to ranges. +-- +-- > group_ranges [-1,0,3,4,5,8,9,12] == [(-1,0),(3,5),(8,9),(12,12)] +-- > group_ranges [3,2,3,4,3] == [(3,3),(2,4),(3,3)] +group_ranges :: (Num t, Eq t) => [t] -> [(t,t)] +group_ranges = + let f l = (head l,last l) + in map f . adjacent_groupBy (\p q -> p + 1 == q) + -- | '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) +group_just = group_on isJust -- | Predicate to determine if all elements of the list are '=='. +-- +-- > all_equal "aaa" == True +all_equal :: Eq a => [a] -> Bool +all_equal l = + case l of + [] -> True + [_] -> True + x:xs -> all id (map (== x) xs) + +-- | Variant using 'nub'. all_eq :: Eq n => [n] -> Bool all_eq = (== 1) . length . nub --- | 'groupBy' of 'sortBy'. +-- | 'group_on' of 'sortOn'. -- -- > 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) +sort_group_on f = group_on f . sortOn f -- | Maybe cons element onto list. -- @@ -374,20 +726,24 @@ EQ -> g p q r -> r --- | Invert 'Ordering'. -ordering_invert :: Ordering -> Ordering -ordering_invert o = - case o of - LT -> GT - EQ -> EQ - GT -> LT +-- | Sequence of comparison functions, continue comparing until not EQ. +-- +-- > compare (1,0) (0,1) == GT +-- > n_stage_compare [compare `on` snd,compare `on` fst] (1,0) (0,1) == LT +n_stage_compare :: [Compare_F a] -> Compare_F a +n_stage_compare l p q = + case l of + [] -> EQ + f:l' -> case f p q of + EQ -> n_stage_compare l' p q + r -> r -- | 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 +sort_to e = map fst . sortOn snd . zip e -- | 'flip' of 'sort_to'. -- @@ -399,12 +755,20 @@ 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)) +-- | 'sortBy' of 'n_stage_compare'. +sort_by_n_stage :: Ord b => [a -> b] -> [a] -> [a] +sort_by_n_stage f = sortBy (n_stage_compare (map (compare `on`) f)) + -- | 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 +-- | 'merge_by' 'compare' 'on'. +merge_on :: Ord x => (a -> x) -> [a] -> [a] -> [a] +merge_on f = merge_by (compare `on` f) + -- | '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)) @@ -449,8 +813,291 @@ GT -> r : recur p q' in recur +-- | First non-ascending pair of elements. +find_non_ascending :: (a -> a -> Ordering) -> [a] -> Maybe (a,a) +find_non_ascending cmp xs = + case xs of + p:q:xs' -> if cmp p q == GT then Just (p,q) else find_non_ascending cmp (q:xs') + _ -> Nothing + +-- | 'isNothing' of 'find_non_ascending'. +is_ascending_by :: (a -> a -> Ordering) -> [a] -> Bool +is_ascending_by cmp = isNothing . find_non_ascending cmp + +-- | 'is_ascending_by' 'compare'. +is_ascending :: Ord a => [a] -> Bool +is_ascending = is_ascending_by compare + +-- | Variant of `elem` that operates on a sorted list, halting. +-- This is 'O.member'. +-- +-- > 16 `elem_ordered` [1,3 ..] == False +-- > 16 `elem` [1,3 ..] == undefined +elem_ordered :: Ord t => t -> [t] -> Bool +elem_ordered = O.member + +-- | Variant of `elemIndex` that operates on a sorted list, halting. +-- +-- > 16 `elemIndex_ordered` [1,3 ..] == Nothing +-- > 16 `elemIndex_ordered` [0,1,4,9,16,25,36,49,64,81,100] == Just 4 +elemIndex_ordered :: Ord t => t -> [t] -> Maybe Int +elemIndex_ordered e = + let recur k l = + case l of + [] -> Nothing + x:l' -> if e == x + then Just k + else if x > e + then Nothing + else recur (k + 1) l' + in recur 0 + +-- | Keep right variant of 'zipWith', where 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 [] + +-- | A 'zipWith' variant that always consumes an element from the left +-- hand side (lhs), but only consumes an element from the right hand +-- side (rhs) if the zip function is 'Right' and not if 'Left'. +-- There's also a secondary function to continue if the rhs ends +-- before the lhs. +zip_with_perhaps_rhs :: (a -> b -> Either c c) -> (a -> c) -> [a] -> [b] -> [c] +zip_with_perhaps_rhs f g lhs rhs = + case (lhs,rhs) of + ([],_) -> [] + (_,[]) -> map g lhs + (p:lhs',q:rhs') -> case f p q of + Left r -> r : zip_with_perhaps_rhs f g lhs' rhs + Right r -> r : zip_with_perhaps_rhs f g lhs' rhs' + +-- | Fill gaps in a sorted association list, range is inclusive at both ends. +-- +-- > let r = [(1,'a'),(2,'x'),(3,'x'),(4,'x'),(5,'b'),(6,'x'),(7,'c'),(8,'x'),(9,'x')] +-- > in fill_gaps_ascending' 'x' (1,9) (zip [1,5,7] "abc") == r +fill_gaps_ascending :: (Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)] +fill_gaps_ascending def_e (l,r) = + let f i (j,e) = if j > i then Left (i,def_e) else Right (j,e) + g i = (i,def_e) + in zip_with_perhaps_rhs f g [l .. r] + +-- | Direct definition. +fill_gaps_ascending' :: (Num n,Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)] +fill_gaps_ascending' def (l,r) = + let recur n x = + if n > r + then [] + else case x of + [] -> zip [n .. r] (repeat def) + (m,e):x' -> if n < m + then (n,def) : recur (n + 1) x + else (m,e) : recur (n + 1) x' + in recur l + +-- | 'minimum' and 'maximum' in one pass. +-- +-- > minmax "minimumandmaximum" == ('a','x') +minmax :: Ord t => [t] -> (t,t) +minmax inp = + case inp of + [] -> error "minmax: null" + x:xs -> let mm p (l,r) = (min p l,max p r) in foldr mm (x,x) xs + -- * 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) + +-- | Append /k/ to the right of /l/ until result has /n/ places. +-- +-- > map (pad_right '0' 2 . return) ['0' .. '9'] +-- > pad_right '0' 12 "1101" == "110100000000" +-- > map (pad_right ' '3) ["S","E-L"] == ["S ","E-L"] +pad_right :: a -> Int -> [a] -> [a] +pad_right k n l = take n (l ++ repeat k) + +-- | Append /k/ to the left of /l/ until result has /n/ places. +-- +-- > map (pad_left '0' 2 . return) ['0' .. '9'] +pad_left :: a -> Int -> [a] -> [a] +pad_left k n l = replicate (n - length l) k ++ l + +-- * Embedding + +-- | Locate first (leftmost) embedding of /q/ in /p/. +-- Return partial indices for failure at 'Left'. +-- +-- > embedding ("embedding","ming") == Right [1,6,7,8] +-- > embedding ("embedding","mind") == Left [1,6,7] +embedding :: Eq t => ([t],[t]) -> Either [Int] [Int] +embedding = + let recur n r (p,q) = + case (p,q) of + (_,[]) -> Right (reverse r) + ([],_) -> Left (reverse r) + (x:p',y:q') -> + let n' = n + 1 + r' = if x == y then n : r else r + in recur n' r' (p',if x == y then q' else q) + in recur 0 [] + +embedding_err :: Eq t => ([t],[t]) -> [Int] +embedding_err = either (error "embedding_err") id . embedding + +-- | Does /q/ occur in sequence, though not necessarily adjacently, in /p/. +-- +-- > is_embedding [1 .. 9] [1,3,7] == True +-- > is_embedding "embedding" "ming" == True +-- > is_embedding "embedding" "mind" == False +is_embedding :: Eq t => [t] -> [t] -> Bool +is_embedding p q = isRight (embedding (p,q)) + +all_embeddings_m :: (Eq t,L.MonadLogic m) => [t] -> [t] -> m [Int] +all_embeddings_m p q = + let q_n = length q + recur p' q' n k = -- n = length k + if n == q_n + then return (reverse k) + else do (m,c) <- L.msum (map return p') + let k0:_ = k + c':_ = q' + L.guard (c == c' && (null k || m > k0)) + let _:p'' = p' + _:q'' = q' + recur p'' q'' (n + 1) (m : k) + in recur (zip [0..] p) q 0 [] + +-- | Enumerate indices for all embeddings of /q/ in /p/. +-- +-- > all_embeddings "all_embeddings" "leg" == [[1,4,12],[1,7,12],[2,4,12],[2,7,12]] +all_embeddings :: Eq t => [t] -> [t] -> [[Int]] +all_embeddings p = L.observeAll . all_embeddings_m p + +-- * Un-list + +-- | Unpack one element list. +unlist1 :: [t] -> Maybe t +unlist1 l = + case l of + [e] -> Just e + _ -> Nothing + +-- | Erroring variant. +unlist1_err :: [t] -> t +unlist1_err = fromMaybe (error "unlist1") . unlist1 + +-- * Traversable + +-- | Replace elements at 'Traversable' with result of joining with elements from list. +-- +-- > let t = Node 0 [Node 1 [Node 2 [],Node 3 []],Node 4 []] +-- > putStrLn $ drawTree (fmap show t) +-- > let u = (adopt_shape (\_ x -> x) "abcde" t) +-- > putStrLn $ drawTree (fmap return u) +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 + +-- * Tree + +{- | 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 ((==) '{',(==) '}') l} +> in catMaybes (flatten t) == l + +> let {d = putStrLn . drawTree . fmap show} +> in d (group_tree ((==) '(',(==) ')') "a(b(cd)ef)ghi") + +-} +group_tree :: (a -> Bool,a -> Bool) -> [a] -> Tree (Maybe a) +group_tree (open_f,close_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) + do_push (r,z) e = + case z of + h:z' -> (r,insert_e h (unit e) : z') + [] -> (unit e : r,[]) + do_open (r,z) = (r,nil:z) + do_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' -> if open_f e + then go (do_push (do_open st) e) x' + else if close_f e + then go (do_close (do_push st e)) x' + else go (do_push st e) x' + in go ([],[]) + +-- * Indexing + +-- | Remove element at index. +-- +-- > remove_ix 5 "remove" == "remov" +-- > remove_ix 5 "short" == undefined +remove_ix :: Int -> [a] -> [a] +remove_ix k l = let (p,q) = splitAt k l in p ++ tail q + +operate_ixs :: Bool -> [Int] -> [a] -> [a] +operate_ixs mode k = + let sel = if mode then notElem else elem + f (n,e) = if n `sel` k then Nothing else Just e + in mapMaybe f . zip [0..] + +-- > select_ixs [1,3] "select" == "ee" +select_ixs :: [Int] -> [a] -> [a] +select_ixs = operate_ixs True + +-- > remove_ixs [1,3,5] "remove" == "rmv" +remove_ixs :: [Int] -> [a] -> [a] +remove_ixs = operate_ixs False + +-- | Replace element at /i/ in /p/ by application of /f/. +-- +-- > replace_ix negate 1 [1..3] == [1,-2,3] +replace_ix :: (a -> a) -> Int -> [a] -> [a] +replace_ix f i p = + let (q,r:s) = splitAt i p + in q ++ (f r : s) + +-- | Cyclic indexing function. +-- +-- > map (at_cyclic "cycle") [0..9] == "cyclecycle" +at_cyclic :: [a] -> Int -> a +at_cyclic l n = + let m = Map.fromList (zip [0..] l) + k = Map.size m + n' = n `mod` k + in fromMaybe (error "cyc_at") (Map.lookup n' m) + diff --git a/Music/Theory/Map.hs b/Music/Theory/Map.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Map.hs @@ -0,0 +1,17 @@ +-- | Map functions. +module Music.Theory.Map where + +import qualified Data.Map as M {- containers -} +import Data.Maybe {- base -} + +-- | Erroring 'M.lookup'. +map_lookup_err :: Ord k => k -> M.Map k c -> c +map_lookup_err k = fromMaybe (error "M.lookup") . M.lookup k + +-- | 'flip' of 'M.lookup'. +map_ix :: Ord k => M.Map k c -> k -> Maybe c +map_ix = flip M.lookup + +-- | 'flip' of 'map_lookup_err'. +map_ix_err :: Ord k => M.Map k c -> k -> c +map_ix_err = flip map_lookup_err diff --git a/Music/Theory/Math.hs b/Music/Theory/Math.hs --- a/Music/Theory/Math.hs +++ b/Music/Theory/Math.hs @@ -5,10 +5,14 @@ import Data.Ratio {- base -} import Numeric {- base -} +import qualified Music.Theory.Math.Convert as T + -- | Real (alias for 'Double'). type R = Double -- | +-- +-- > integral_and_fractional_parts 1.5 == (1,0.5) integral_and_fractional_parts :: (Integral i, RealFrac t) => t -> (i,t) integral_and_fractional_parts n = if n >= 0 @@ -26,11 +30,40 @@ fractional_part :: RealFrac a => a -> a fractional_part = snd . integer_and_fractional_parts +-- | 'floor' of 'T.real_to_double'. +real_floor :: (Real r,Integral i) => r -> i +real_floor = floor . T.real_to_double + +-- | Type specialised 'real_floor'. +real_floor_int :: Real r => r -> Int +real_floor_int = real_floor + +-- | 'round' of 'T.real_to_double'. +real_round :: (Real r,Integral i) => r -> i +real_round = round . T.real_to_double + +-- | Type specialised 'real_round'. +real_round_int :: Real r => r -> Int +real_round_int = real_round + +-- | Is /r/ zero to /k/ decimal places. +-- +-- > map (flip zero_to_precision 0.00009) [4,5] == [True,False] +-- > zero_to_precision 4 1.00009 == False +zero_to_precision :: Real r => Int -> r -> Bool +zero_to_precision k r = real_floor_int (r * (fromIntegral ((10::Int) ^ k))) == 0 + +-- | Is /r/ whole to /k/ decimal places. +-- +-- > map (flip whole_to_precision 1.00009) [4,5] == [True,False] +whole_to_precision :: Real r => Int -> r -> Bool +whole_to_precision k = zero_to_precision k . fractional_part . T.real_to_double + -- | -- -- > plotTable1 (map sawtooth_wave [-2.0,-1.99 .. 2.0]) sawtooth_wave :: RealFrac a => a -> a -sawtooth_wave n = n - fromInteger (floor n) +sawtooth_wave n = n - floor_f n -- | Pretty printer for 'Rational' that elides denominators of @1@. -- @@ -60,7 +93,7 @@ rational_simplifies (n,d) = gcd n d /= 1 -- | 'numerator' and 'denominator' of rational. -rational_nd :: Integral t => Ratio t -> (t,t) +rational_nd :: Ratio t -> (t,t) rational_nd r = (numerator r,denominator r) -- | Rational as a whole number, or 'Nothing'. @@ -71,6 +104,19 @@ rational_whole_err :: Integral a => Ratio a -> a rational_whole_err = fromMaybe (error "rational_whole") . rational_whole +-- | Show rational to /n/ decimal places. +-- +-- > let r = approxRational pi 1e-100 +-- > r == 884279719003555 / 281474976710656 +-- > show_rational_decimal 12 r == "3.141592653590" +show_rational_decimal :: Int -> Rational -> String +show_rational_decimal n r = + let d = round (abs r * 10^n) + s = show (d :: Integer) + s' = replicate (n - length s + 1) '0' ++ s + (h, f) = splitAt (length s' - n) s' + in (if r < 0 then "-" else "") ++ h ++ "." ++ f + -- | Variant of 'showFFloat'. The 'Show' instance for floats resorts -- to exponential notation very readily. -- @@ -78,6 +124,10 @@ realfloat_pp :: RealFloat a => Int -> a -> String realfloat_pp k n = showFFloat (Just k) n "" +-- | Show /r/ as float to /k/ places. +real_pp :: Real t => Int -> t -> String +real_pp k t = showFFloat (Just k) (T.real_to_double t) "" + -- | Type specialised 'realfloat_pp'. float_pp :: Int -> Float -> String float_pp = realfloat_pp @@ -96,3 +146,62 @@ LT -> '-' : show (abs n) EQ -> "" GT -> '+' : show n + +-- | 'fromInteger' . 'floor'. +floor_f :: (RealFrac a, Num b) => a -> b +floor_f = fromInteger . floor + +-- | Round /b/ to nearest multiple of /a/. +-- +-- > map (round_to 0.25) [0,0.1 .. 1] == [0.0,0.0,0.25,0.25,0.5,0.5,0.5,0.75,0.75,1.0,1.0] +-- > map (round_to 25) [0,10 .. 100] == [0,0,25,25,50,50,50,75,75,100,100] +round_to :: RealFrac n => n -> n -> n +round_to a b = if a == 0 then b else floor_f ((b / a) + 0.5) * a + +-- * One-indexed + +-- | One-indexed 'mod' function. +-- +-- > map (`oi_mod` 5) [1..10] == [1,2,3,4,5,1,2,3,4,5] +oi_mod :: Integral a => a -> a -> a +oi_mod n m = ((n - 1) `mod` m) + 1 + +-- | One-indexed 'divMod' function. +-- +-- > map (`oi_divMod` 5) [1,3 .. 9] == [(0,1),(0,3),(0,5),(1,2),(1,4)] +oi_divMod :: Integral t => t -> t -> (t, t) +oi_divMod n m = let (i,j) = (n - 1) `divMod` m in (i,j + 1) + +-- * I = integral + +-- | Integral square root function. +-- +-- > map i_square_root [0,1,4,9,16,25,36,49,64,81,100] == [0 .. 10] +-- > map i_square_root [4 .. 16] == [2,2,2,2,2,3,3,3,3,3,3,3,4] +i_square_root :: Integral t => t -> t +i_square_root n = + let babylon a = + let b = quot (a + quot n a) 2 + in if a > b then babylon b else a + in case compare n 0 of + GT -> babylon n + EQ -> 0 + _ -> error "i_square_root: negative?" + +-- * Interval + +-- | (0,1) = {x | 0 < x < 1} +in_open_interval :: Ord a => (a, a) -> a -> Bool +in_open_interval (p,q) n = p < n && n < q + +-- | [0,1] = {x | 0 ≤ x ≤ 1} +in_closed_interval :: Ord a => (a, a) -> a -> Bool +in_closed_interval (p,q) n = p <= n && n <= q + +-- | (p,q] (0,1] = {x | 0 < x ≤ 1} +in_left_half_open_interval :: Ord a => (a, a) -> a -> Bool +in_left_half_open_interval (p,q) n = p < n && n <= q + +-- | [p,q) [0,1) = {x | 0 ≤ x < 1} +in_right_half_open_interval :: Ord a => (a, a) -> a -> Bool +in_right_half_open_interval (p,q) n = p <= n && n < q diff --git a/Music/Theory/Math/Convert.hs b/Music/Theory/Math/Convert.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Convert.hs @@ -0,0 +1,1121 @@ +{- | Specialised type conversions, see mk/mk-convert.hs + +> map int_to_word8 [-1,0,255,256] == [255,0,255,0] +> map int_to_word8_maybe [-1,0,255,256] == [Nothing,Just 0,Just 255,Nothing] + +> map integer_to_int64_maybe [-2 ^ 63 - 1,2 ^ 63] == [Nothing,Nothing] +> map integer_to_word64_maybe [2 ^64 - 1,2 ^ 64] == [Just 18446744073709551615,Nothing] + +> map int16_to_float [-1,0,1] == [-1,0,1] + +-} +module Music.Theory.Math.Convert where + +import Data.Int {- base -} +import Data.Word {- base -} + +-- | Type specialised 'realToFrac' +real_to_float :: Real t => t -> Float +real_to_float = realToFrac + +-- | Type specialised 'realToFrac' +real_to_double :: Real t => t -> Double +real_to_double = realToFrac + +-- | Type specialised 'realToFrac' +double_to_float :: Double -> Float +double_to_float = realToFrac + +-- | Type specialised 'realToFrac' +float_to_double :: Float -> Double +float_to_double = realToFrac + +-- AUTOGEN (see mk/mk-convert.hs) + +-- | Type specialised 'fromIntegral' +word8_to_word16 :: Word8 -> Word16 +word8_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_word32 :: Word8 -> Word32 +word8_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_word64 :: Word8 -> Word64 +word8_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_int8 :: Word8 -> Int8 +word8_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_int16 :: Word8 -> Int16 +word8_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_int32 :: Word8 -> Int32 +word8_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_int64 :: Word8 -> Int64 +word8_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_int :: Word8 -> Int +word8_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_integer :: Word8 -> Integer +word8_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_float :: Word8 -> Float +word8_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_double :: Word8 -> Double +word8_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_word8 :: Word16 -> Word8 +word16_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_word32 :: Word16 -> Word32 +word16_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_word64 :: Word16 -> Word64 +word16_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_int8 :: Word16 -> Int8 +word16_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_int16 :: Word16 -> Int16 +word16_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_int32 :: Word16 -> Int32 +word16_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_int64 :: Word16 -> Int64 +word16_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_int :: Word16 -> Int +word16_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_integer :: Word16 -> Integer +word16_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_float :: Word16 -> Float +word16_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_double :: Word16 -> Double +word16_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_word8 :: Word32 -> Word8 +word32_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_word16 :: Word32 -> Word16 +word32_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_word64 :: Word32 -> Word64 +word32_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int8 :: Word32 -> Int8 +word32_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int16 :: Word32 -> Int16 +word32_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int32 :: Word32 -> Int32 +word32_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int64 :: Word32 -> Int64 +word32_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int :: Word32 -> Int +word32_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_integer :: Word32 -> Integer +word32_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_float :: Word32 -> Float +word32_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_double :: Word32 -> Double +word32_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_word8 :: Word64 -> Word8 +word64_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_word16 :: Word64 -> Word16 +word64_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_word32 :: Word64 -> Word32 +word64_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_int8 :: Word64 -> Int8 +word64_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_int16 :: Word64 -> Int16 +word64_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_int32 :: Word64 -> Int32 +word64_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_int64 :: Word64 -> Int64 +word64_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_int :: Word64 -> Int +word64_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_integer :: Word64 -> Integer +word64_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_float :: Word64 -> Float +word64_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_double :: Word64 -> Double +word64_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_word8 :: Int8 -> Word8 +int8_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_word16 :: Int8 -> Word16 +int8_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_word32 :: Int8 -> Word32 +int8_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_word64 :: Int8 -> Word64 +int8_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_int16 :: Int8 -> Int16 +int8_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_int32 :: Int8 -> Int32 +int8_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_int64 :: Int8 -> Int64 +int8_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_int :: Int8 -> Int +int8_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_integer :: Int8 -> Integer +int8_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_float :: Int8 -> Float +int8_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +int8_to_double :: Int8 -> Double +int8_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_word8 :: Int16 -> Word8 +int16_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_word16 :: Int16 -> Word16 +int16_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_word32 :: Int16 -> Word32 +int16_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_word64 :: Int16 -> Word64 +int16_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_int8 :: Int16 -> Int8 +int16_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_int32 :: Int16 -> Int32 +int16_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_int64 :: Int16 -> Int64 +int16_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_int :: Int16 -> Int +int16_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_integer :: Int16 -> Integer +int16_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_float :: Int16 -> Float +int16_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_double :: Int16 -> Double +int16_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_word8 :: Int32 -> Word8 +int32_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_word16 :: Int32 -> Word16 +int32_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_word32 :: Int32 -> Word32 +int32_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_word64 :: Int32 -> Word64 +int32_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_int8 :: Int32 -> Int8 +int32_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_int16 :: Int32 -> Int16 +int32_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_int64 :: Int32 -> Int64 +int32_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_int :: Int32 -> Int +int32_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_integer :: Int32 -> Integer +int32_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_float :: Int32 -> Float +int32_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_double :: Int32 -> Double +int32_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_word8 :: Int64 -> Word8 +int64_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_word16 :: Int64 -> Word16 +int64_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_word32 :: Int64 -> Word32 +int64_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_word64 :: Int64 -> Word64 +int64_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_int8 :: Int64 -> Int8 +int64_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_int16 :: Int64 -> Int16 +int64_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_int32 :: Int64 -> Int32 +int64_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_int :: Int64 -> Int +int64_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_integer :: Int64 -> Integer +int64_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_float :: Int64 -> Float +int64_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_double :: Int64 -> Double +int64_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_word8 :: Int -> Word8 +int_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_word16 :: Int -> Word16 +int_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_word32 :: Int -> Word32 +int_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_word64 :: Int -> Word64 +int_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int8 :: Int -> Int8 +int_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int16 :: Int -> Int16 +int_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int32 :: Int -> Int32 +int_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int64 :: Int -> Int64 +int_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_integer :: Int -> Integer +int_to_integer = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_float :: Int -> Float +int_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_double :: Int -> Double +int_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_word8 :: Integer -> Word8 +integer_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_word16 :: Integer -> Word16 +integer_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_word32 :: Integer -> Word32 +integer_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_word64 :: Integer -> Word64 +integer_to_word64 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_int8 :: Integer -> Int8 +integer_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_int16 :: Integer -> Int16 +integer_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_int32 :: Integer -> Int32 +integer_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_int64 :: Integer -> Int64 +integer_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_int :: Integer -> Int +integer_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_float :: Integer -> Float +integer_to_float = fromIntegral + +-- | Type specialised 'fromIntegral' +integer_to_double :: Integer -> Double +integer_to_double = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_word16_maybe :: Word8 -> Maybe Word16 +word8_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word8_to_word32_maybe :: Word8 -> Maybe Word32 +word8_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word8_to_word64_maybe :: Word8 -> Maybe Word64 +word8_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word8_to_int8_maybe :: Word8 -> Maybe Int8 +word8_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word8_to_int16_maybe :: Word8 -> Maybe Int16 +word8_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word8_to_int32_maybe :: Word8 -> Maybe Int32 +word8_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word8_to_int64_maybe :: Word8 -> Maybe Int64 +word8_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word8_to_int_maybe :: Word8 -> Maybe Int +word8_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_word8_maybe :: Word16 -> Maybe Word8 +word16_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_word32_maybe :: Word16 -> Maybe Word32 +word16_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_word64_maybe :: Word16 -> Maybe Word64 +word16_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_int8_maybe :: Word16 -> Maybe Int8 +word16_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_int16_maybe :: Word16 -> Maybe Int16 +word16_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_int32_maybe :: Word16 -> Maybe Int32 +word16_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_int64_maybe :: Word16 -> Maybe Int64 +word16_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word16_to_int_maybe :: Word16 -> Maybe Int +word16_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_word8_maybe :: Word32 -> Maybe Word8 +word32_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_word16_maybe :: Word32 -> Maybe Word16 +word32_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_word64_maybe :: Word32 -> Maybe Word64 +word32_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_int8_maybe :: Word32 -> Maybe Int8 +word32_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_int16_maybe :: Word32 -> Maybe Int16 +word32_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_int32_maybe :: Word32 -> Maybe Int32 +word32_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_int64_maybe :: Word32 -> Maybe Int64 +word32_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word32_to_int_maybe :: Word32 -> Maybe Int +word32_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_word8_maybe :: Word64 -> Maybe Word8 +word64_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_word16_maybe :: Word64 -> Maybe Word16 +word64_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_word32_maybe :: Word64 -> Maybe Word32 +word64_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_int8_maybe :: Word64 -> Maybe Int8 +word64_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_int16_maybe :: Word64 -> Maybe Int16 +word64_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_int32_maybe :: Word64 -> Maybe Int32 +word64_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_int64_maybe :: Word64 -> Maybe Int64 +word64_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +word64_to_int_maybe :: Word64 -> Maybe Int +word64_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_word8_maybe :: Int8 -> Maybe Word8 +int8_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_word16_maybe :: Int8 -> Maybe Word16 +int8_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_word32_maybe :: Int8 -> Maybe Word32 +int8_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_word64_maybe :: Int8 -> Maybe Word64 +int8_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_int16_maybe :: Int8 -> Maybe Int16 +int8_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_int32_maybe :: Int8 -> Maybe Int32 +int8_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_int64_maybe :: Int8 -> Maybe Int64 +int8_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int8_to_int_maybe :: Int8 -> Maybe Int +int8_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_word8_maybe :: Int16 -> Maybe Word8 +int16_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_word16_maybe :: Int16 -> Maybe Word16 +int16_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_word32_maybe :: Int16 -> Maybe Word32 +int16_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_word64_maybe :: Int16 -> Maybe Word64 +int16_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_int8_maybe :: Int16 -> Maybe Int8 +int16_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_int32_maybe :: Int16 -> Maybe Int32 +int16_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_int64_maybe :: Int16 -> Maybe Int64 +int16_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int16_to_int_maybe :: Int16 -> Maybe Int +int16_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_word8_maybe :: Int32 -> Maybe Word8 +int32_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_word16_maybe :: Int32 -> Maybe Word16 +int32_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_word32_maybe :: Int32 -> Maybe Word32 +int32_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_word64_maybe :: Int32 -> Maybe Word64 +int32_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_int8_maybe :: Int32 -> Maybe Int8 +int32_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_int16_maybe :: Int32 -> Maybe Int16 +int32_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_int64_maybe :: Int32 -> Maybe Int64 +int32_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int32_to_int_maybe :: Int32 -> Maybe Int +int32_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_word8_maybe :: Int64 -> Maybe Word8 +int64_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_word16_maybe :: Int64 -> Maybe Word16 +int64_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_word32_maybe :: Int64 -> Maybe Word32 +int64_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_word64_maybe :: Int64 -> Maybe Word64 +int64_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_int8_maybe :: Int64 -> Maybe Int8 +int64_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_int16_maybe :: Int64 -> Maybe Int16 +int64_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_int32_maybe :: Int64 -> Maybe Int32 +int64_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int64_to_int_maybe :: Int64 -> Maybe Int +int64_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_word8_maybe :: Int -> Maybe Word8 +int_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_word16_maybe :: Int -> Maybe Word16 +int_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_word32_maybe :: Int -> Maybe Word32 +int_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_word64_maybe :: Int -> Maybe Word64 +int_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_int8_maybe :: Int -> Maybe Int8 +int_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_int16_maybe :: Int -> Maybe Int16 +int_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_int32_maybe :: Int -> Maybe Int32 +int_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +int_to_int64_maybe :: Int -> Maybe Int64 +int_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_word8_maybe :: Integer -> Maybe Word8 +integer_to_word8_maybe n = + if n < fromIntegral (minBound::Word8) || + n > fromIntegral (maxBound::Word8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_word16_maybe :: Integer -> Maybe Word16 +integer_to_word16_maybe n = + if n < fromIntegral (minBound::Word16) || + n > fromIntegral (maxBound::Word16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_word32_maybe :: Integer -> Maybe Word32 +integer_to_word32_maybe n = + if n < fromIntegral (minBound::Word32) || + n > fromIntegral (maxBound::Word32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_word64_maybe :: Integer -> Maybe Word64 +integer_to_word64_maybe n = + if n < fromIntegral (minBound::Word64) || + n > fromIntegral (maxBound::Word64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_int8_maybe :: Integer -> Maybe Int8 +integer_to_int8_maybe n = + if n < fromIntegral (minBound::Int8) || + n > fromIntegral (maxBound::Int8) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_int16_maybe :: Integer -> Maybe Int16 +integer_to_int16_maybe n = + if n < fromIntegral (minBound::Int16) || + n > fromIntegral (maxBound::Int16) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_int32_maybe :: Integer -> Maybe Int32 +integer_to_int32_maybe n = + if n < fromIntegral (minBound::Int32) || + n > fromIntegral (maxBound::Int32) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_int64_maybe :: Integer -> Maybe Int64 +integer_to_int64_maybe n = + if n < fromIntegral (minBound::Int64) || + n > fromIntegral (maxBound::Int64) + then Nothing + else Just (fromIntegral n) + +-- | Type specialised 'fromIntegral' +integer_to_int_maybe :: Integer -> Maybe Int +integer_to_int_maybe n = + if n < fromIntegral (minBound::Int) || + n > fromIntegral (maxBound::Int) + then Nothing + else Just (fromIntegral n) diff --git a/Music/Theory/Math/OEIS.hs b/Music/Theory/Math/OEIS.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/OEIS.hs @@ -0,0 +1,27 @@ +-- | The On-Line Encyclopedia of Integer Sequences, +module Music.Theory.Math.OEIS where + +-- | +-- +-- The squares of the non-negative integers. +-- +-- > import Data.List +-- > [0,1,4,9,16,25,36,49,64,81,100] `isInfixOf` a000290 +a000290 :: Integral n => [n] +a000290 = let square n = n * n in map square [0..] + +-- | +a002267 :: Num n => [n] +a002267 = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 41, 47, 59, 71] + +-- | +-- +-- Loh-Shu magic square, attributed to the legendary Fu Xi (Fuh-Hi). +a126709 :: Num n => [n] +a126709 = [4, 9, 2, 3, 5, 7, 8, 1, 6] + +-- | +-- +-- Jaina inscription of the twelfth or thirteenth century, Khajuraho, India. +a126710 :: Num n => [n] +a126710 = [7, 12, 1, 14, 2, 13, 8, 11, 16, 3, 10, 5, 9, 6, 15, 4] diff --git a/Music/Theory/Maybe.hs b/Music/Theory/Maybe.hs --- a/Music/Theory/Maybe.hs +++ b/Music/Theory/Maybe.hs @@ -1,7 +1,11 @@ -- | Extensions to "Data.Maybe". module Music.Theory.Maybe where --- import Data.Maybe {- base -} +import Data.Maybe {- base -} + +-- | Variant with error text. +from_just :: String -> Maybe a -> a +from_just err = fromMaybe (error err) -- | Variant of unzip. -- diff --git a/Music/Theory/Meter/Barlow_1987.hs b/Music/Theory/Meter/Barlow_1987.hs --- a/Music/Theory/Meter/Barlow_1987.hs +++ b/Music/Theory/Meter/Barlow_1987.hs @@ -42,7 +42,7 @@ else r -- | Specialised variant of 'fromIntegral'. -to_r :: (Integral n,Show n) => n -> R +to_r :: Integral n => n -> R to_r = fromIntegral -- | Variant on 'div' with input constraints. @@ -91,7 +91,7 @@ -- | 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 :: Integral n => n -> [n] reverse_primes n = reverse (genericTake n primes) -- | Generate prime stratification for /n/. diff --git a/Music/Theory/Metric/Polansky_1996.hs b/Music/Theory/Metric/Polansky_1996.hs --- a/Music/Theory/Metric/Polansky_1996.hs +++ b/Music/Theory/Metric/Polansky_1996.hs @@ -116,7 +116,7 @@ -- -- > 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 :: 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) @@ -151,7 +151,7 @@ -- -- > 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 :: Fractional 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 @@ -162,23 +162,23 @@ -- > 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 :: (Real a,Real 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 :: 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 :: (Real 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 :: Floating a => [a] -> [a] -> a olm_no_delta_squared_second_order = second_order olm_no_delta_squared -- | Second order binomial coefficient, p.307 @@ -199,7 +199,7 @@ -- > ord_hist [LT,GT,GT] == (1,0,2) ord_hist :: Integral t => [Ordering] -> (t,t,t) ord_hist x = - let h = L.histogram x + let h = L.generic_histogram x f n = fromMaybe 0 (lookup n h) in (f LT,f EQ,f GT) @@ -279,7 +279,7 @@ 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 :: Fractional n => 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) @@ -293,7 +293,7 @@ -- -- > 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 :: Fractional n => Interval a n -> [a] -> [a] -> n ocm f p q = let (z,c,_) = ocm_zcm f p q in z / c @@ -302,7 +302,7 @@ -- -- > 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 :: (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) diff --git a/Music/Theory/Monad.hs b/Music/Theory/Monad.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Monad.hs @@ -0,0 +1,10 @@ +-- | Monad functions. +module Music.Theory.Monad where + +repeatM_ :: (Monad m) => m a -> m () +repeatM_ = sequence_ . repeat + +iterateM_ :: (Monad m) => st -> (st -> m st) -> m () +iterateM_ st f = do + st' <- f st + iterateM_ st' f diff --git a/Music/Theory/Ord.hs b/Music/Theory/Ord.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Ord.hs @@ -0,0 +1,38 @@ +-- | 'Ordering' functions +module Music.Theory.Ord where + +-- | Specialised 'fromEnum'. +ord_to_int :: Ordering -> Int +ord_to_int = fromEnum + +-- | Specialised 'toEnum'. +int_to_ord :: Int -> Ordering +int_to_ord = toEnum + +-- | 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 + +-- | Given 'Ordering', re-order pair, +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) + +-- | Variant where the comparison function may not compute a value. +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) diff --git a/Music/Theory/Parse.hs b/Music/Theory/Parse.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Parse.hs @@ -0,0 +1,16 @@ +module Music.Theory.Parse where + +import Data.Maybe {- base -} + +import qualified Text.ParserCombinators.Parsec as P {- parsec -} + +-- | A 'Char' parser. +type P a = P.GenParser Char () a + +-- | Boolean 'P' for given 'Char'. +is_char :: Char -> P Bool +is_char = fmap isJust . P.optionMaybe . P.char + +-- | Parse 'Integral'. +parse_int :: Integral i => P i +parse_int = fmap (fromInteger . read) (P.many1 P.digit) diff --git a/Music/Theory/Permutations.hs b/Music/Theory/Permutations.hs --- a/Music/Theory/Permutations.hs +++ b/Music/Theory/Permutations.hs @@ -39,7 +39,7 @@ -- -- > 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 :: P.Permute -> [a] -> [a] apply_permutation f p = map (p !!) (P.elems f) -- | Composition of 'apply_permutation' and 'from_cycles'. @@ -48,7 +48,7 @@ -- > 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 :: [[Int]] -> [a] -> [a] apply_permutation_c = apply_permutation . from_cycles -- | True if the inverse of /p/ is /p/. @@ -155,4 +155,8 @@ map P.cycles (permutations_n 3) map P.cycles (permutations_n 4) partition not (map non_invertible (permutations_n 4)) + +import Data.List {- base -} +putStrLn $ unlines $ map unwords $ permutations ["A0","A1","B0"] + -} diff --git a/Music/Theory/Permutations/List.hs b/Music/Theory/Permutations/List.hs --- a/Music/Theory/Permutations/List.hs +++ b/Music/Theory/Permutations/List.hs @@ -1,14 +1,16 @@ -- | List permutation functions. module Music.Theory.Permutations.List where -import qualified Math.Combinatorics.Multiset as C -import qualified Music.Theory.Permutations as P +import Data.List {- base -} +import qualified Math.Combinatorics.Multiset as C {- multiset-comb -} +import qualified Music.Theory.Permutations as P {- hmt -} + -- | Generate all permutations. -- -- > permutations [0,3] == [[0,3],[3,0]] -- > length (permutations [1..5]) == P.n_permutations 5 -permutations :: (Eq a) => [a] -> [[a]] +permutations :: [a] -> [[a]] permutations i = let f p = P.apply_permutation p i in map f (P.permutations_n (length i)) @@ -18,3 +20,20 @@ -- > 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 + +factorial :: (Enum a, Num a) => a -> a +factorial n = product [1..n] + +-- | Calculate number of permutations of a multiset. +-- +-- > let r = factorial 11 `div` product (map factorial [1,4,4,2]) +-- > in multiset_permutations_n "MISSISSIPPI" == r +-- +-- > multiset_permutations_n "MISSISSIPPI" == 34650 +-- > length (multiset_permutations "MISSISSIPPI") == 34650 +multiset_permutations_n :: Ord a => [a] -> Int +multiset_permutations_n x = + let occ = map length . group . sort + n = factorial (length x) + d = product $ map factorial $ occ x + in n `div` d diff --git a/Music/Theory/Permutations/Morris_1984.hs b/Music/Theory/Permutations/Morris_1984.hs --- a/Music/Theory/Permutations/Morris_1984.hs +++ b/Music/Theory/Permutations/Morris_1984.hs @@ -8,6 +8,7 @@ import Data.Char {- base -} import Data.List {- base -} import Data.List.Split {- split -} +import Data.Maybe {- base -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Permutations as T {- hmt -} @@ -76,11 +77,14 @@ swap_all :: [a] -> [a] swap_all = flatten_pairs . map swap_pair . T.adj2 2 +numeric_spelling_tbl :: [(Char,Int)] +numeric_spelling_tbl = zip "1234567890ETABCD" [1 .. 16] + -- | Parse abbreviated 'Hold' notation, characters are hexedecimal. -- --- > to_abbrev "38A" == [3,8,10] +-- > to_abbrev "380ETA" == [3,8,10,11,12,13] to_abbrev :: String -> [Int] -to_abbrev = map digitToInt +to_abbrev = map (fromMaybe (error "to_abbrev") . flip lookup numeric_spelling_tbl) -- | Given a 'Hold' notation, generate permutation cycles. -- @@ -99,6 +103,14 @@ else Left n : rec (m + 1) l' in rec 1 +-- | Given two sequences, derive the one-indexed "hold" list. +-- +-- > derive_holds ("12345","13254") == [1] +derive_holds :: (Eq a,Enum n,Num n) => ([a],[a]) -> [n] +derive_holds (p,q) = + let f n (i,j) = if i == j then Just n else Nothing + in catMaybes (zipWith f [1..] (zip p q)) + -- | Two-tuple to two element list. pair_to_list :: (t,t) -> [t] pair_to_list (p,q) = [p,q] @@ -120,14 +132,14 @@ -- | 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 :: 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 :: Int -> Change -> [a] -> [a] apply_change k p l = case p of Swap_All -> swap_all l @@ -140,7 +152,7 @@ -- > ,[[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 :: Method -> [a] -> ([a],[[a]]) apply_method m l = let k = length l f z e = (apply_change k e z,z) @@ -165,9 +177,7 @@ -- * Methods --- | Cambridgeshire Slow Course Doubles. --- --- +-- | -- -- > length (closed_method cambridgeshire_slow_course_doubles [1..5]) == 3 cambridgeshire_slow_course_doubles :: Method @@ -195,9 +205,7 @@ 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 @@ -205,12 +213,19 @@ 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 +-- > let m = closed_method smithsonian_surprise_royal [1..10] +-- > (length m,nub (map length m),sum (map length m)) == (9,[40],360) smithsonian_surprise_royal :: Method smithsonian_surprise_royal = - let a = ("-3A-14-5A-16-347A-18-1456-5A-16-7A",Just "12") + let a = ("-30-14-50-16-3470-18-1456-50-16-70",Just "12") in parse_method a + +-- | +-- +-- > let m = closed_method ecumenical_surprise_maximus [1..12] +-- > (length m,nub (map length m),sum (map length m)) == (11,[48],528) +ecumenical_surprise_maximus :: Method +ecumenical_surprise_maximus = + parse_method ("x3Tx14x5Tx16x7Tx1238x149Tx50x16x7Tx18.90.ET",Just "12") diff --git a/Music/Theory/Pitch.hs b/Music/Theory/Pitch.hs --- a/Music/Theory/Pitch.hs +++ b/Music/Theory/Pitch.hs @@ -4,12 +4,45 @@ import Data.Char {- base -} import Data.Function {- base -} import Data.List {- base -} +import Data.Maybe {- base -} +import Text.Printf {- 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 -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +-- * Octave & pitch-class (generic) + +-- | 'Octave' and 'PitchClass' duple. +type Octave_PitchClass i = (i,i) + +-- | Normalise 'Octave_PitchClass' value, ie. ensure pitch-class is in (0,11). +octave_pitchclass_nrm :: Integral i => Octave_PitchClass i -> Octave_PitchClass i +octave_pitchclass_nrm (o,pc) = + if pc > 11 + then octave_pitchclass_nrm (o+1,pc-12) + else if pc < 0 + then octave_pitchclass_nrm (o-1,pc+12) + else (o,pc) + +-- | Transpose 'Octave_PitchClass' value. +octave_pitchclass_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i +octave_pitchclass_trs n (o,pc) = + let pc' = fromIntegral pc + k = pc' + n + (i,j) = k `divMod` 12 + in (fromIntegral o + fromIntegral i,fromIntegral j) + +-- | 'Octave_PitchClass' value to integral /midi/ note number. +octave_pitchclass_to_midi :: Integral i => Octave_PitchClass i -> i +octave_pitchclass_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc + +-- | Inverse of 'octave_pitchclass_to_midi'. +midi_to_octave_pitchclass :: Integral i => i -> Octave_PitchClass i +midi_to_octave_pitchclass n = (n - 12) `divMod` 12 + +-- * Octave & PitchClass + -- | Pitch classes are modulo twelve integers. type PitchClass = Int @@ -17,30 +50,93 @@ type Octave = Int -- | 'Octave' and 'PitchClass' duple. -type Octave_PitchClass i = (i,i) type OctPC = (Octave,PitchClass) +-- | Translate from generic octave & pitch-class duple. +to_octpc :: (Integral pc, Integral oct) => (oct,pc) -> OctPC +to_octpc (oct,pc) = (fromIntegral oct,fromIntegral pc) + +-- | Normalise 'OctPC'. +-- +-- > octpc_nrm (4,16) == (5,4) +octpc_nrm :: OctPC -> OctPC +octpc_nrm = octave_pitchclass_nrm + +-- | Transpose 'OctPC'. +-- +-- > octpc_trs 7 (4,9) == (5,4) +-- > octpc_trs (-11) (4,9) == (3,10) +octpc_trs :: Int -> OctPC -> OctPC +octpc_trs = octave_pitchclass_trs + +-- | 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 + +-- | Midi note number +type Midi = Int + +-- | 'OctPC' value to integral /midi/ note number. +-- +-- > map octpc_to_midi [(0,0),(2,6),(4,9),(9,0)] == [12,42,69,120] +-- > map octpc_to_midi [(0,9),(8,0)] == [21,108] +octpc_to_midi :: OctPC -> Midi +octpc_to_midi = octave_pitchclass_to_midi + +-- | Inverse of 'octpc_to_midi'. +-- +-- > map midi_to_octpc [40,69] == [(2,4),(4,9)] +midi_to_octpc :: Midi -> OctPC +midi_to_octpc = midi_to_octave_pitchclass + +-- * Octave & fractional pitch-class + +-- | Fractional midi note number. +type FMidi = Double + +-- | Fractional octave pitch-class (octave is integral, pitch-class is fractional). +type FOctPC = (Int,Double) + +-- | 'fromIntegral' of 'octpc_to_midi'. +octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n +octpc_to_fmidi = fromIntegral . octave_pitchclass_to_midi + +-- | Fractional midi to fractional octave pitch-class. +-- +-- > fmidi_to_foctpc 69.5 == (4,9.5) +fmidi_to_foctpc :: RealFrac f => f -> (Octave,f) +fmidi_to_foctpc n = let o = (floor n - 12) `div` 12 in (o,n - (fromIntegral (o + 1) * 12)) + +-- | Octave of fractional midi note number. +fmidi_octave :: RealFrac f => f -> Octave +fmidi_octave = fst . fmidi_to_foctpc + +foctpc_to_fmidi :: RealFrac f => (Octave,f) -> f +foctpc_to_fmidi (o,pc) = (fromIntegral (o + 1) * 12) + pc + +-- | Move fractional midi note number to indicated octave. +-- +-- > map (fmidi_in_octave 1) [59.5,60.5] == [35.5,24.5] +fmidi_in_octave :: RealFrac f => Octave -> f -> f +fmidi_in_octave o m = let (_,pc) = fmidi_to_foctpc m in foctpc_to_fmidi (o,pc) + +-- * Pitch + -- | Common music notation pitch value. -data Pitch = Pitch {note :: Note_T - ,alteration :: Alteration_T +data Pitch = Pitch {note :: T.Note_T + ,alteration :: T.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 @@ -48,25 +144,25 @@ 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 + in Pitch n (T.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 +pitch_to_octpc = midi_to_octave_pitchclass . pitch_to_midi -- | Is 'Pitch' 12-ET. pitch_is_12et :: Pitch -> Bool -pitch_is_12et = alteration_is_12et . alteration +pitch_is_12et = T.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 + let a' = T.alteration_to_diff_err a + n' = T.note_to_pc n o' = fromIntegral o in 12 + o' * 12 + n' + a' @@ -75,17 +171,17 @@ -- > 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 + let a' = T.alteration_to_fdiff a o' = fromIntegral o - n' = fromInteger (note_to_pc n) + n' = fromInteger (T.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 +-- > map pitch_to_pc [Pitch A Natural 4,Pitch F Sharp 4] == [9,6] +-- > map pitch_to_pc [Pitch C Flat 4,Pitch B Sharp 5] == [11,0] pitch_to_pc :: Pitch -> PitchClass -pitch_to_pc (Pitch n a _) = note_to_pc n + alteration_to_diff_err a +pitch_to_pc (Pitch n a _) = (T.note_to_pc n + T.alteration_to_diff_err a) `mod` 12 -- | 'Pitch' comparison, implemented via 'pitch_to_fmidi'. -- @@ -95,93 +191,131 @@ 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 +-- * Spelling --- | 'fromIntegral' of 'octpc_to_midi'. -octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n -octpc_to_fmidi = fromIntegral . octpc_to_midi +-- | Function to spell a 'PitchClass'. +type Spelling n = n -> (T.Note_T,T.Alteration_T) --- | 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 +-- | Variant of 'Spelling' for incomplete functions. +type Spelling_M i = i -> Maybe (T.Note_T,T.Alteration_T) --- | Enumerate range, inclusive. +-- | Given 'Spelling' function translate from 'OctPC' notation to 'Pitch'. -- --- > 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'] +-- > octpc_to_pitch T.pc_spell_sharp (4,6) == Pitch T.F T.Sharp 4 +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) -- | 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 +midi_to_pitch sp = octpc_to_pitch sp . midi_to_octave_pitchclass +-- | Print fractional midi note number as ET12 pitch with cents detune in parentheses. +-- +-- > fmidi_et12_cents_pp 66.5 == "F♯4(+50)" +fmidi_et12_cents_pp :: Spelling PitchClass -> Double -> String +fmidi_et12_cents_pp sp = + let f (m,c) = + let d = T.num_diff_str (round c :: Int) + d' = if null d then "" else "(" ++ d ++ ")" + in pitch_pp (midi_to_pitch sp m) ++ d' + in f . midi_detune_normalise . fmidi_to_midi_detune + -- | 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 pc_spell_ks 69.25 == Nothing +fmidi_to_pitch :: RealFrac n => Spelling PitchClass -> n -> Maybe 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 + in case T.alteration_edit_quarter_tone q a of + Nothing -> Nothing + Just a' -> Just (Pitch n a' o) +-- | Erroring variant. +-- +-- > import Music.Theory.Pitch.Spelling +-- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 65.5) == "F𝄲4" +-- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 66.5) == "F𝄰4" +-- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 67.5) == "A𝄭4" +-- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 69.5) == "B𝄭4" +fmidi_to_pitch_err :: (Show n,RealFrac n) => Spelling Int -> n -> Pitch +fmidi_to_pitch_err sp m = fromMaybe (error (show ("fmidi_to_pitch",m))) (fmidi_to_pitch sp m) + -- | 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 :: (RealFrac n,Show n) => Spelling Int -> n -> Pitch -> Pitch pitch_tranpose sp n p = let m = pitch_to_fmidi p - in fmidi_to_pitch sp (m + n) + in fmidi_to_pitch_err sp (m + n) +-- | Displacement of /q/ into octave of /p/. +fmidi_in_octave_of :: RealFrac f => f -> f -> f +fmidi_in_octave_of p = fmidi_in_octave (fmidi_octave p) + +-- | Octave displacement of /m2/ that is nearest /m1/. +-- +-- > let {p = octpc_to_fmidi (2,1);q = map octpc_to_fmidi [(4,11),(4,0),(4,1)]} +-- > in map (fmidi_in_octave_nearest p) q == [35,36,37] +fmidi_in_octave_nearest :: RealFrac n => n -> n -> n +fmidi_in_octave_nearest m1 m2 = + let m2' = fmidi_in_octave (fmidi_octave m1) m2 + m2'' = [m2' - 12,m2',m2' + 12] + d = map (abs . (m1 -)) m2'' + z = sortOn snd (zip m2'' d) + in fst (head z) + +-- | Displacement of /q/ into octave above /p/. +-- +-- > fmidi_in_octave_of 69 51 == 63 +-- > fmidi_in_octave_nearest 69 51 == 63 +-- > fmidi_in_octave_above 69 51 == 75 +fmidi_in_octave_above :: RealFrac a => a -> a -> a +fmidi_in_octave_above p q = let r = fmidi_in_octave_nearest p q in if r < p then r + 12 else r + +-- | Displacement of /q/ into octave below /p/. +-- +-- > fmidi_in_octave_of 69 85 == 61 +-- > fmidi_in_octave_nearest 69 85 == 73 +-- > fmidi_in_octave_below 69 85 == 61 +fmidi_in_octave_below :: RealFrac a => a -> a -> a +fmidi_in_octave_below p q = let r = fmidi_in_octave_nearest p q in if r > p then r - 12 else r + +cps_in_octave' :: Floating f => (f -> f -> f) -> f -> f -> f +cps_in_octave' f p = fmidi_to_cps . f (cps_to_fmidi p) . cps_to_fmidi + +-- | CPS form of 'fmidi_in_octave_nearest'. +-- +-- > map cps_octave [440,256] == [4,4] +-- > round (cps_in_octave_nearest 440 256) == 512 +cps_in_octave_nearest :: (Floating f,RealFrac f) => f -> f -> f +cps_in_octave_nearest = cps_in_octave' fmidi_in_octave_nearest + +-- | Raise or lower the frequency /q/ by octaves until it is in the +-- octave starting at /p/. +-- +-- > cps_in_octave_above 55.0 392.0 == 98.0 +cps_in_octave_above :: (Ord a, Fractional a) => a -> a -> a +cps_in_octave_above p = + let go q = if q > p * 2 then go (q / 2) else if q < p then go (q * 2) else q + in go + +-- > cps_in_octave_above' 55.0 392.0 == 97.99999999999999 +cps_in_octave_above' :: (Floating f,RealFrac f) => f -> f -> f +cps_in_octave_above' = cps_in_octave' fmidi_in_octave_above + +cps_in_octave_below :: (Floating f,RealFrac f) => f -> f -> f +cps_in_octave_below = cps_in_octave' fmidi_in_octave_below + -- | Set octave of /p2/ so that it nearest to /p1/. -- -- > import Music.Theory.Pitch.Name as T @@ -190,13 +324,9 @@ -- > 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) + let f = pitch_to_fmidi :: Pitch -> Double + o = fmidi_octave (fmidi_in_octave_nearest (f p1) (f p2)) + in p2 {octave = o} -- | Raise 'Note_T' of 'Pitch', account for octave transposition. -- @@ -225,8 +355,8 @@ 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) + T.ThreeQuarterToneFlat -> pitch_note_lower (Pitch n T.QuarterToneSharp o) + T.ThreeQuarterToneSharp -> pitch_note_raise (Pitch n T.QuarterToneFlat o) _ -> Pitch n a o -- | Apply function to 'octave' of 'PitchClass'. @@ -237,22 +367,46 @@ -- * Frequency (CPS) --- | /Midi/ note number to cycles per second. +-- | /Midi/ note number to cycles per second, given frequency of ISO A4. +midi_to_cps_f0 :: (Integral i,Floating f) => f -> i -> f +midi_to_cps_f0 f0 = fmidi_to_cps_f0 f0 . fromIntegral + +-- | 'midi_to_cps_f0' 440. -- -- > 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 +midi_to_cps = midi_to_cps_f0 440 --- | Fractional /midi/ note number to cycles per second. +-- | Fractional /midi/ note number to cycles per second, given frequency of ISO A4. +fmidi_to_cps_f0 :: Floating a => a -> a -> a +fmidi_to_cps_f0 f0 i = f0 * (2 ** ((i - 69) * (1 / 12))) + +-- | 'fmidi_to_cps_f0' 440. -- -- > 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 = fmidi_to_cps_f0 440 --- | 'fmidi_to_cps' of 'pitch_to_fmidi'. +-- | 'fmidi_to_cps' of 'pitch_to_fmidi', given frequency of ISO A4. +pitch_to_cps_f0 :: Floating n => n -> Pitch -> n +pitch_to_cps_f0 f0 = fmidi_to_cps_f0 f0 . pitch_to_fmidi + +-- | 'pitch_to_cps_f0' 440. pitch_to_cps :: Floating n => Pitch -> n -pitch_to_cps = fmidi_to_cps . pitch_to_fmidi +pitch_to_cps = pitch_to_cps_f0 440 +-- | Frequency (cps = cycles per second) to fractional /midi/ note +-- number, given frequency of ISO A4 (mnn = 69). +cps_to_fmidi_f0 :: Floating a => a -> a -> a +cps_to_fmidi_f0 f0 a = (logBase 2 (a * (1 / f0)) * 12) + 69 + +-- | 'cps_to_fmidi_f0' @440@. +-- +-- > 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 = cps_to_fmidi_f0 440 + -- | Frequency (cycles per second) to /midi/ note number, ie. 'round' -- of 'cps_to_fmidi'. -- @@ -260,40 +414,123 @@ 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. +-- | 'midi_to_cps_f0' of 'octpc_to_midi', given frequency of ISO A4. +octpc_to_cps_f0 :: (Integral i,Floating n) => n -> Octave_PitchClass i -> n +octpc_to_cps_f0 f0 = midi_to_cps_f0 f0 . octave_pitchclass_to_midi + +-- | 'octpc_to_cps_f0' 440. -- --- > 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 +-- > octpc_to_cps (4,9) == 440 +octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n +octpc_to_cps = octpc_to_cps_f0 440 +-- | '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_octave_pitchclass . cps_to_midi + +cps_octave :: (Floating f,RealFrac f) => f -> Octave +cps_octave = fst . cps_to_octpc + +-- * MIDI detune (cents) + -- | Midi note number with cents detune. -type Midi_Detune = (Int,Double) +type Midi_Detune' c = (Int,c) +-- | Is cents in (-50,+50]. +-- +-- > map cents_is_normal [-250,-75,75,250] == replicate 4 False +cents_is_normal :: (Num c, Ord c) => c -> Bool +cents_is_normal c = c > (-50) && c <= 50 + +-- | 'cents_is_normal' of 'snd'. +midi_detune_is_normal :: (Num c, Ord c) => Midi_Detune' c -> Bool +midi_detune_is_normal = cents_is_normal . snd + +-- | In normal form the detune is in the range (-50,+50] instead of [0,100) or wider. +-- +-- > map midi_detune_normalise [(60,-250),(60,-75),(60,75),(60,250)] +midi_detune_normalise :: (Ord c,Num c) => Midi_Detune' c -> Midi_Detune' c +midi_detune_normalise (m,c) = + if c > 50 + then midi_detune_normalise (m + 1,c - 100) + else if c > (-50) + then (m,c) + else midi_detune_normalise (m - 1,c + 100) + +-- | Inverse of 'cps_to_midi_detune', given frequency of ISO @A4@. +midi_detune_to_cps_f0 :: Real c => Double -> Midi_Detune' c -> Double +midi_detune_to_cps_f0 f0 (m,c) = fmidi_to_cps_f0 f0 (fromIntegral m + (realToFrac c / 100)) + +-- | Inverse of 'cps_to_midi_detune'. +-- +-- > map midi_detune_to_cps [(69,0),(68,100)] == [440,440] +midi_detune_to_cps :: Real c => Midi_Detune' c -> Double +midi_detune_to_cps = midi_detune_to_cps_f0 440 + +-- | 'Midi_Detune' to fractional midi note number. +-- +-- > midi_detune_to_fmidi (60,50.0) == 60.50 +midi_detune_to_fmidi :: Real c => Midi_Detune' c -> Double +midi_detune_to_fmidi (mnn,c) = fromIntegral mnn + (realToFrac c / 100) + +-- | 'Midi_Detune' to 'Pitch', detune must be precisely at a notateable Pitch. +-- +-- > let p = Pitch {note = C, alteration = QuarterToneSharp, octave = 4} +-- > in midi_detune_to_pitch T.pc_spell_ks (midi_detune_nearest_24et (60,35)) == p +midi_detune_to_pitch :: Real c => Spelling Int -> Midi_Detune' c -> Pitch +midi_detune_to_pitch sp = fmidi_to_pitch_err sp . cps_to_fmidi . midi_detune_to_cps + +-- | Midi note number with real-valued cents detune. +type Midi_Detune = Midi_Detune' Double + +-- | Fractional midi note number to 'Midi_Detune'. +-- +-- > fmidi_to_midi_detune 60.50 == (60,50.0) +fmidi_to_midi_detune :: Double -> Midi_Detune +fmidi_to_midi_detune mnn = + let (n,c) = T.integral_and_fractional_parts mnn + in (n,c * 100) + -- | 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)) +cps_to_midi_detune = fmidi_to_midi_detune . cps_to_fmidi --- | 'midi_to_cps' of 'octpc_to_midi'. +-- | Round /detune/ value to nearest multiple of @50@, normalised. -- --- > 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 +-- > map midi_detune_nearest_24et [(59,70),(59,80)] == [(59,50),(60,00)] +midi_detune_nearest_24et :: Midi_Detune -> Midi_Detune +midi_detune_nearest_24et (m,dt) = midi_detune_normalise (m,T.round_to 50 dt) --- | '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 +-- * MIDI cents +-- | Midi note number with integral cents detune. +type Midi_Cents = Midi_Detune' Int + +midi_detune_to_midi_cents :: Midi_Detune -> Midi_Cents +midi_detune_to_midi_cents (m,c) = (m,round c) + +-- | Printed as /fmidi/ value with cents to two places. Must be normal. +-- +-- > map midi_cents_pp [(60,0),(60,25)] == ["60.00","60.25"] +midi_cents_pp :: Midi_Cents -> String +midi_cents_pp (m,c) = if cents_is_normal c then printf "%d.%02d" m c else error "midi_cents_pp" + -- * Parsers +-- | Parse possible octave from single integer. +-- +-- > map (parse_octave 2) ["","4","x","11"] +parse_octave :: Num a => a -> String -> Maybe a +parse_octave def_o o = + case o of + [] -> Just def_o + [n] -> if isDigit n + then Just (fromIntegral (digitToInt n)) + else Nothing + _ -> Nothing + -- | Slight generalisation of ISO pitch representation. Allows octave -- to be elided, pitch names to be lower case, and double sharps -- written as @##@. @@ -304,59 +541,69 @@ -- > 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 + let mk n a o = case T.parse_note_t True n of Nothing -> Nothing - Just n' -> fmap (Pitch n' a) (oct o) + Just n' -> fmap (Pitch n' a) (parse_octave def_o 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 + n:'b':'b':o -> mk n T.DoubleFlat o + n:'#':'#':o -> mk n T.DoubleSharp o + n:'x':o -> mk n T.DoubleSharp o + n:'b':o -> mk n T.Flat o + n:'#':o -> mk n T.Sharp o + n:o -> mk n T.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") +-- | 'error' variant. +parse_iso_pitch_err :: String -> Pitch +parse_iso_pitch_err = fromMaybe (error "parse_iso_pitch") . parse_iso_pitch + -- * Pretty printers -- | Pretty printer for 'Pitch' (unicode, see 'alteration_symbol'). +-- Option selects if 'Natural's are printed. -- --- > pitch_pp (Pitch E Flat 4) == "E♭4" --- > pitch_pp (Pitch F QuarterToneSharp 3) == "F𝄲3" +-- > pitch_pp_opt (True,True) (Pitch T.E T.Natural 4) == "E♮4" +pitch_pp_opt :: (Bool,Bool) -> Pitch -> String +pitch_pp_opt (show_nat,show_oct) (Pitch n a o) = + let a' = if a == T.Natural && not show_nat then "" else [T.alteration_symbol a] + rem_oct_f c = isDigit c || c == '-' -- negative octave values... + rem_oct = if show_oct then id else T.dropWhileRight rem_oct_f + in rem_oct (show n ++ a' ++ show o) + +-- | 'pitch_pp_opt' with default options, ie. (False,True). +-- +-- > pitch_pp (Pitch T.E T.Natural 4) == "E4" +-- > pitch_pp (Pitch T.E T.Flat 4) == "E♭4" +-- > pitch_pp (Pitch T.F T.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_pp = pitch_pp_opt (False,True) --- | 'Pitch' printed without octave. +-- | 'pitch_pp_opt' with options (False,False). +-- +-- > pitch_class_pp (Pitch T.C T.ThreeQuarterToneSharp 0) == "C𝄰" pitch_class_pp :: Pitch -> String -pitch_class_pp = T.dropWhileRight isDigit . pitch_pp +pitch_class_pp = pitch_pp_opt (False,False) -- | Sequential list of /n/ pitch class names starting from /k/. -- +-- > unwords (pitch_class_names_12et 0 12) == "C C♯ D E♭ E F F♯ G A♭ A B♭ B" -- > 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 +pitch_class_names_12et :: Integral n => Spelling n -> n -> n -> [String] +pitch_class_names_12et sp k n = + let f = pitch_class_pp . midi_to_pitch sp 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 C ThreeQuarterToneSharp 4) -- error pitch_pp_iso :: Pitch -> String -pitch_pp_iso (Pitch n a o) = show n ++ alteration_iso a ++ show o +pitch_pp_iso (Pitch n a o) = show n ++ T.alteration_iso a ++ show o -- | Pretty printer for 'Pitch' (ASCII, see 'alteration_tonh'). -- @@ -366,7 +613,7 @@ 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 + in n' ++ T.alteration_tonh a ++ show o -- | Pretty printer for 'Pitch' (Tonhöhe, see 'alteration_tonh'). -- @@ -377,9 +624,46 @@ 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' + (T.B,T.Natural) -> "H" ++ o' + (T.B,T.Flat) -> "B" ++ o' + (T.B,T.DoubleFlat) -> "Heses" ++ o' + (T.A,T.Flat) -> "As" ++ o' + (T.E,T.Flat) -> "Es" ++ o' + _ -> show n ++ T.alteration_tonh a ++ o' + +-- * 24ET + +{- The 24ET pitch-class universe, with /sharp/ spellings, in octave '4'. + +> length pc24et_univ == 24 + +> let r = "C C𝄲 C♯ C𝄰 D D𝄲 D♯ D𝄰 E E𝄲 F F𝄲 F♯ F𝄰 G G𝄲 G♯ G𝄰 A A𝄲 A♯ A𝄰 B B𝄲" +> in unwords (map pitch_class_pp pc24et_univ) == r + +-} +pc24et_univ :: [Pitch] +pc24et_univ = + let a = [T.Natural,T.QuarterToneSharp,T.Sharp,T.ThreeQuarterToneSharp] + f (n,k) = map (\i -> Pitch n (a !! i) 4) [0 .. k - 1] + in concatMap f (zip T.note_seq [4,4,2,4,4,4,2]) + +-- | 'genericIndex' into 'pc24et_univ'. +-- +-- > pitch_class_pp (pc24et_to_pitch 13) == "F𝄰" +pc24et_to_pitch :: Integral i => i -> Pitch +pc24et_to_pitch = genericIndex pc24et_univ + +-- * Pitch, rational alteration. + +-- | Generalised pitch, given by a generalised alteration. +data Pitch_R = Pitch_R T.Note_T T.Alteration_R Octave + deriving (Eq,Show) + +-- | Pretty printer for 'Pitch_R'. +pitch_r_pp :: Pitch_R -> String +pitch_r_pp (Pitch_R n (_,a) o) = show n ++ a ++ show o + +-- | 'Pitch_R' printed without octave. +pitch_r_class_pp :: Pitch_R -> String +pitch_r_class_pp = T.dropWhileRight isDigit . pitch_r_pp + diff --git a/Music/Theory/Pitch/Chord.hs b/Music/Theory/Pitch/Chord.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Chord.hs @@ -0,0 +1,159 @@ +module Music.Theory.Pitch.Chord where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Text.ParserCombinators.Parsec as P {- parsec -} + +import qualified Music.Theory.Key as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} + +type PC = (T.Note_T,T.Alteration_T) + +pc_pp :: (T.Note_T, T.Alteration_T) -> [Char] +pc_pp (n,a) = T.note_pp n : T.alteration_iso a + +-- | D = dominant, M = major +data Extension = D7 | M7 deriving (Eq,Show) + +extension_tbl :: Num n => [(Extension, (String,n))] +extension_tbl = [(D7,("7",10)),(M7,("M7",11))] + +extension_dat :: Num n => Extension -> (String,n) +extension_dat = flip T.lookup_err extension_tbl + +extension_pp :: Extension -> String +extension_pp = fst . (extension_dat :: Extension -> (String,Int)) + +extension_to_pc :: Num n => Extension -> n +extension_to_pc = snd . extension_dat + +data Chord_Type = Major | Minor + | Augmented | Diminished + | Diminished_7 | Half_Diminished + | Suspended_2 | Suspended_4 + deriving (Eq,Show) + +is_suspended :: Chord_Type -> Bool +is_suspended ty = ty `elem` [Suspended_2,Suspended_4] + +-- | Names and pc-sets for chord types. +-- The name used here is in the first position, alternates follow. +chord_type_tbl :: Num n => [(Chord_Type,([String],[n]))] +chord_type_tbl = + [(Major,(["","M","maj"],[0,4,7])) + ,(Minor,(["m","min"],[0,3,7])) + ,(Augmented,(["+","aug"],[0,4,8])) + ,(Diminished,(["o","dim"],[0,3,6])) + ,(Diminished_7,(["o7","dim7"],[0,3,6,9])) + ,(Half_Diminished,(["Ø","halfdim","m7(b5)"],[0,3,6,10])) + ,(Suspended_2,(["sus2"],[0,2,7])) + ,(Suspended_4,(["sus4"],[0,5,7]))] + +chord_type_dat :: Num n => Chord_Type -> ([String],[n]) +chord_type_dat = flip T.lookup_err chord_type_tbl + +chord_type_pp :: Chord_Type -> String +chord_type_pp = head . fst . (chord_type_dat :: Chord_Type -> ([String],[Int])) + +chord_type_pcset :: Num n => Chord_Type -> [n] +chord_type_pcset = snd . chord_type_dat + +-- (root,mode,extensions,bass) +data Chord = CH PC Chord_Type (Maybe Extension) (Maybe PC) + deriving (Show) + +chord_pcset :: Chord -> (Maybe Int,[Int]) +chord_pcset (CH pc ty ex bs) = + let get = m_error "chord_pcset" . T.note_alteration_to_pc + pc' = get pc + ty' = chord_type_pcset ty + ex' = fmap extension_to_pc ex + bs' = fmap get bs + ch = map ((`mod` 12) . (+ pc')) (ty' ++ maybe [] return ex') + ch' = maybe ch (flip delete ch) bs' + in (bs',ch') + +bass_pp :: PC -> String +bass_pp = ('/' :) . pc_pp + +chord_pp :: Chord -> String +chord_pp (CH pc ty ex bs) = + let (pre_ty,post_ty) = if is_suspended ty + then (Nothing,Just ty) + else (Just ty,Nothing) + in concat [pc_pp pc + ,maybe "" chord_type_pp pre_ty + ,maybe "" extension_pp ex + ,maybe "" chord_type_pp post_ty + ,maybe "" bass_pp bs] + +type P a = P.GenParser Char () a + +m_error :: String -> Maybe a -> a +m_error txt = fromMaybe (error txt) + +p_note_t :: P T.Note_T +p_note_t = + fmap + (m_error "p_note_t" . T.parse_note_t False) + (P.oneOf "ABCDEFG") + +p_alteration_t_iso :: P T.Alteration_T +p_alteration_t_iso = + fmap + (m_error "p_alteration_t_iso" . T.symbol_to_alteration_iso) + (P.oneOf "b#x") + +p_pc :: P PC +p_pc = do + n <- p_note_t + a <- P.optionMaybe p_alteration_t_iso + return (n,fromMaybe T.Natural a) + +p_mode_m :: P T.Mode_T +p_mode_m = P.option T.Major_Mode (P.char 'm' >> return T.Minor_Mode) + +p_chord_type :: P Chord_Type +p_chord_type = + let m = P.char 'm' >> return Minor + au = P.char '+' >> return Augmented + dm = P.char 'o' >> return Diminished + dm7 = P.try (P.string "o7" >> return Diminished_7) + hdm = P.char 'Ø' >> return Half_Diminished + sus2 = P.try (P.string "sus2" >> return Suspended_2) + sus4 = P.try (P.string "sus4" >> return Suspended_4) + in P.option Major (P.choice [dm7,dm,hdm,au,sus2,sus4,m]) + +p_extension :: P Extension +p_extension = + let d7 = P.char '7' >> return D7 + m7 = P.try (P.string "M7" >> return M7) + in P.choice [d7,m7] + +p_bass :: P (Maybe PC) +p_bass = P.optionMaybe (P.char '/' >> p_pc) + +p_chord :: P Chord +p_chord = do + pc <- p_pc + ty <- p_chord_type + ex <- P.optionMaybe p_extension + b <- p_bass + ty' <- p_chord_type + let ty'' = case (ty,ty') of + (Major,Suspended_2) -> Suspended_2 + (Major,Suspended_4) -> Suspended_4 + (_,Major) -> ty -- ie. nothing + _ -> error ("trailing type not sus2 or sus4: " ++ show ty') + return (CH pc ty'' ex b) + +-- > let ch = words "CmM7 C#o EbM7 Fo7 Gx/D C/E GØ/F Bbsus4/C E7sus2" +-- > let c = map parse_chord ch +-- > map chord_pp c == ch +-- > map chord_pcset c +parse_chord :: String -> Chord +parse_chord = + either (\e -> error ("parse_chord failed\n" ++ show e)) id . + P.parse p_chord "" diff --git a/Music/Theory/Pitch/Note.hs b/Music/Theory/Pitch/Note.hs --- a/Music/Theory/Pitch/Note.hs +++ b/Music/Theory/Pitch/Note.hs @@ -1,28 +1,41 @@ -- | Common music notation note and alteration values. module Music.Theory.Pitch.Note where +import Data.Char {- base -} import Data.Maybe {- base -} --- * Note +import qualified Music.Theory.List as T {- hmt -} +-- * Note_T + -- | 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) + deriving (Eq,Enum,Bounded,Ord,Read,Show) +-- | Note sequence as usually understood, ie. 'C' - 'B'. +note_seq :: [Note_T] +note_seq = [C .. B] + +-- | Char variant of 'show'. +note_pp :: Note_T -> Char +note_pp = head . show + +-- | Table of 'Note_T' and corresponding pitch-classes. +note_pc_tbl :: Num i => [(Note_T,i)] +note_pc_tbl = zip [C .. B] [0,2,4,5,7,9,11] + -- | 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 +note_to_pc :: Num i => Note_T -> i +note_to_pc n = fromMaybe (error "note_to_pc") (lookup n note_pc_tbl) +-- | Inverse of 'note_to_pc'. +-- +-- > mapMaybe pc_to_note [0,4,7] == [C,E,G] +pc_to_note :: (Eq i,Num i) => i -> Maybe Note_T +pc_to_note i = T.reverse_lookup i note_pc_tbl + -- | Modal transposition of 'Note_T' value. -- -- > note_t_transpose C 2 == E @@ -32,15 +45,38 @@ n' = fromEnum (maxBound::Note_T) + 1 in toEnum ((x' + n) `mod` n') +-- | Parser from 'Char', case insensitive flag. +-- +-- > mapMaybe (parse_note True) "CDEFGab" == [C,D,E,F,G,A,B] +parse_note_t :: Bool -> Char -> Maybe Note_T +parse_note_t ci c = + let tbl = zip "CDEFGAB" [C,D,E,F,G,A,B] + in lookup (if ci then toUpper c else c) tbl + +-- | 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''] + -- * 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) +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 @@ -146,6 +182,18 @@ ThreeQuarterToneSharp -> Sharp _ -> x +alteration_symbol_tbl :: [(Alteration_T,Char)] +alteration_symbol_tbl = + [(DoubleFlat,'𝄫') + ,(ThreeQuarterToneFlat,'𝄭') + ,(Flat,'♭') + ,(QuarterToneFlat,'𝄳') + ,(Natural,'♮') + ,(QuarterToneSharp,'𝄲') + ,(Sharp,'♯') + ,(ThreeQuarterToneSharp,'𝄰') + ,(DoubleSharp,'𝄪')] + -- | 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 @@ -153,33 +201,39 @@ -- -- > 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 -> '𝄪' +alteration_symbol a = fromMaybe (error "alteration_symbol") (lookup a alteration_symbol_tbl) --- | The @ISO@ ASCII spellings for alterations. Naturals as written +-- | Inverse of 'alteration_symbol'. +-- +-- > mapMaybe symbol_to_alteration "♭♮♯" == [Flat,Natural,Sharp] +symbol_to_alteration :: Char -> Maybe Alteration_T +symbol_to_alteration c = T.reverse_lookup c alteration_symbol_tbl + +-- | Variant of 'symbol_to_alteration' that /also/ recognises @b@ for 'Flat' +-- and @#@ for 'Sharp' and 'x' for double sharp. +symbol_to_alteration_iso :: Char -> Maybe Alteration_T +symbol_to_alteration_iso c = + case c of + 'b' -> Just Flat + '#' -> Just Sharp + 'x' -> Just DoubleSharp + _ -> symbol_to_alteration c + +alteration_iso_tbl :: [(Alteration_T,String)] +alteration_iso_tbl = + [(DoubleFlat,"bb") + ,(Flat,"b") + ,(Natural,"") + ,(Sharp,"#") + ,(DoubleSharp,"x")] + +-- | The @ISO@ ASCII spellings for alterations. Naturals are written -- as the empty string. -- -- > mapMaybe alteration_iso_m [Flat .. Sharp] == ["b","","#"] +-- > mapMaybe alteration_iso_m [DoubleFlat,DoubleSharp] == ["bb","x"] 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" +alteration_iso_m a = lookup a alteration_iso_tbl -- | The @ISO@ ASCII spellings for alterations. alteration_iso :: Alteration_T -> String @@ -206,19 +260,40 @@ ThreeQuarterToneSharp -> "isih" DoubleSharp -> "isis" --- * Generalised Alteration +-- * 12-ET --- | Generalised alteration, given as a rational semitone difference +note_alteration_to_pc :: (Note_T,Alteration_T) -> Maybe Int +note_alteration_to_pc (n,a) = + let n_pc = note_to_pc n + in fmap ((`mod` 12) . (+ n_pc)) (alteration_to_diff a) + +-- > map note_alteration_to_pc_err [(A,DoubleSharp),(B,Sharp),(C,Flat),(C,DoubleFlat)] +note_alteration_to_pc_err :: (Note_T, Alteration_T) -> Int +note_alteration_to_pc_err = fromMaybe (error "note_alteration_to_pc") . note_alteration_to_pc + +-- | Note & alteration sequence in key-signature spelling. +note_alteration_ks :: [(Note_T, Alteration_T)] +note_alteration_ks = + [(C,Natural),(C,Sharp),(D,Natural),(E,Flat),(E,Natural),(F,Natural) + ,(F,Sharp),(G,Natural),(A,Flat),(A,Natural),(B,Flat),(B,Natural)] + +-- | Table connecting pitch class number with 'note_alteration_ks'. +pc_note_alteration_ks_tbl :: Integral i => [((Note_T,Alteration_T),i)] +pc_note_alteration_ks_tbl = zip note_alteration_ks [0..11] + +-- | 'T.reverse_lookup' of 'pc_note_alteration_ks_tbl'. +pc_to_note_alteration_ks :: Integral i => i -> Maybe (Note_T,Alteration_T) +pc_to_note_alteration_ks i = T.reverse_lookup i pc_note_alteration_ks_tbl + +-- * Rational Alteration + +-- | Alteration given as a rational semitone difference -- and a string representation of the alteration. -type Alteration_T' = (Rational,String) +type Alteration_R = (Rational,String) --- | Transform 'Alteration_T' to 'Alteration_T''. +-- | Transform 'Alteration_T' to 'Alteration_R'. -- -- > 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) - +alteration_r :: Alteration_T -> Alteration_R +alteration_r a = (alteration_to_fdiff a,[alteration_symbol a]) diff --git a/Music/Theory/Pitch/Note/Name.hs b/Music/Theory/Pitch/Note/Name.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Note/Name.hs @@ -0,0 +1,88 @@ +-- | Constants names for notes. /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.Note.Name where + +import Music.Theory.Pitch.Note + +ceses,deses,eeses,feses,geses,aeses,beses :: (Note_T,Alteration_T) +ceses = (C,DoubleFlat) +deses = (D,DoubleFlat) +eeses = (E,DoubleFlat) +feses = (F,DoubleFlat) +geses = (G,DoubleFlat) +aeses = (A,DoubleFlat) +beses = (B,DoubleFlat) + +ceseh,deseh,eeseh,feseh,geseh,aeseh,beseh :: (Note_T,Alteration_T) +ceseh = (C,ThreeQuarterToneFlat) +deseh = (D,ThreeQuarterToneFlat) +eeseh = (E,ThreeQuarterToneFlat) +feseh = (F,ThreeQuarterToneFlat) +geseh = (G,ThreeQuarterToneFlat) +aeseh = (A,ThreeQuarterToneFlat) +beseh = (B,ThreeQuarterToneFlat) + +ces,des,ees,fes,ges,aes,bes :: (Note_T,Alteration_T) +ces = (C,Flat) +des = (D,Flat) +ees = (E,Flat) +fes = (F,Flat) +ges = (G,Flat) +aes = (A,Flat) +bes = (B,Flat) + +ceh,deh,eeh,feh,geh,aeh,beh :: (Note_T,Alteration_T) +ceh = (C,QuarterToneFlat) +deh = (D,QuarterToneFlat) +eeh = (E,QuarterToneFlat) +feh = (F,QuarterToneFlat) +geh = (G,QuarterToneFlat) +aeh = (A,QuarterToneFlat) +beh = (B,QuarterToneFlat) + +c,d,e,f,g,a,b :: (Note_T,Alteration_T) +c = (C,Natural) +d = (D,Natural) +e = (E,Natural) +f = (F,Natural) +g = (G,Natural) +a = (A,Natural) +b = (B,Natural) + +cih,dih,eih,fih,gih,aih,bih :: (Note_T,Alteration_T) +cih = (C,QuarterToneSharp) +dih = (D,QuarterToneSharp) +eih = (E,QuarterToneSharp) +fih = (F,QuarterToneSharp) +gih = (G,QuarterToneSharp) +aih = (A,QuarterToneSharp) +bih = (B,QuarterToneSharp) + +cis,dis,eis,fis,gis,ais,bis :: (Note_T,Alteration_T) +cis = (C,Sharp) +dis = (D,Sharp) +eis = (E,Sharp) +fis = (F,Sharp) +gis = (G,Sharp) +ais = (A,Sharp) +bis = (B,Sharp) + +cisih,disih,eisih,fisih,gisih,aisih,bisih :: (Note_T,Alteration_T) +cisih = (C,ThreeQuarterToneSharp) +disih = (D,ThreeQuarterToneSharp) +eisih = (E,ThreeQuarterToneSharp) +fisih = (F,ThreeQuarterToneSharp) +gisih = (G,ThreeQuarterToneSharp) +aisih = (A,ThreeQuarterToneSharp) +bisih = (B,ThreeQuarterToneSharp) + +cisis,disis,eisis,fisis,gisis,aisis,bisis :: (Note_T,Alteration_T) +cisis = (C,DoubleSharp) +disis = (D,DoubleSharp) +eisis = (E,DoubleSharp) +fisis = (F,DoubleSharp) +gisis = (G,DoubleSharp) +aisis = (A,DoubleSharp) +bisis = (B,DoubleSharp) diff --git a/Music/Theory/Pitch/Spelling.hs b/Music/Theory/Pitch/Spelling.hs --- a/Music/Theory/Pitch/Spelling.hs +++ b/Music/Theory/Pitch/Spelling.hs @@ -1,75 +1,19 @@ -- | 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 +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Cluster as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Key as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Table as T {- hmt -} --- | 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 +spell_octpc_set :: [T.OctPC] -> [T.Pitch] +spell_octpc_set o = + case T.octpc_spell_implied_key o of + Just r -> r + Nothing -> + case T.spell_cluster_octpc o of + Just r -> r + Nothing -> map T.octpc_to_pitch_ks o --- | 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 +spell_midi_set :: [T.Midi] -> [T.Pitch] +spell_midi_set = spell_octpc_set . map T.midi_to_octpc diff --git a/Music/Theory/Pitch/Spelling/Cluster.hs b/Music/Theory/Pitch/Spelling/Cluster.hs --- a/Music/Theory/Pitch/Spelling/Cluster.hs +++ b/Music/Theory/Pitch/Spelling/Cluster.hs @@ -1,128 +1,175 @@ -- | Spelling for chromatic clusters. module Music.Theory.Pitch.Spelling.Cluster where -import Data.List -import Music.Theory.Pitch -import Music.Theory.Pitch.Name +import Data.List {- base -} --- | Spelling table for chromatic clusters. +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +import Music.Theory.Pitch.Note.Name {- hmt -} + +-- | Form of cluster with smallest outer boundary interval. -- --- > 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])] +-- > cluster_normal_order [0,1,11] == [11,0,1] +cluster_normal_order :: [T.PitchClass] -> [T.PitchClass] +cluster_normal_order = + let with_bounds x = ((last x - head x) `mod` 12,x) + in snd . head . sort . map with_bounds . T.rotations +-- | Normal order starting in indicated octave. +-- +-- > cluster_normal_order_octpc 3 [0,1,11] == [(3,11),(4,0),(4,1)] +cluster_normal_order_octpc :: T.Octave -> [T.PitchClass] -> [T.OctPC] +cluster_normal_order_octpc o pc = + let pc_n = cluster_normal_order pc + pc_0 = head pc_n + in map (\x -> (if x >= pc_0 then o else o + 1,x)) pc_n + +-- | True if 'sort' of cluster is not equal to 'cluster_normal_order'. +-- +-- > map cluster_is_multiple_octave [[0,1,11],[1,2,3],[1,2,11]] == [True,False,True] +cluster_is_multiple_octave :: [T.PitchClass] -> Bool +cluster_is_multiple_octave x = sort x /= cluster_normal_order x + +-- | Spelling table for chromatic and near-chromatic clusters, +-- pitch-classes are in cluster order. +-- +-- > let f (p,q) = (p == map T.note_alteration_to_pc_err q) +-- > in all f spell_cluster_table +spell_cluster_table :: [([T.PitchClass],[(T.Note_T,T.Alteration_T)])] +spell_cluster_table = + [([0,1,2,3],[bis,cis,d,ees]) + ,([0,1,2],[bis,cis,d]) + ,([0,1,3],[c,des,ees]) + ,([0,1],[c,des]) + ,([0,2,3],[c,d,ees]) + ,([0,2],[c,d]) + ,([0],[c]) + ,([1,2,3],[cis,d,ees]) + ,([1,2],[cis,d]) + ,([10,0,1,2],[ais,bis,cis,d]) + ,([10,0,1,3],[bes,c,des,ees]) + ,([10,0,1],[bes,c,des]) + ,([10,0,2,3],[bes,c,d,ees]) + ,([10,0,2],[bes,c,d]) + ,([10,1,2,3],[bes,cis,d,ees]) + ,([10,1,2],[ais,cis,d]) + ,([10,11,0,1,2,3],[ais,b,c,cis,d,ees]) -- overlap... + ,([10,11,0,1],[ais,b,c,des]) + ,([10,11,0,2],[ais,b,c,d]) + ,([10,11,0,3],[ais,b,c,dis]) + ,([10,11,0],[ais,b,c]) + ,([10,11,1,2],[ais,b,cis,d]) + ,([10,11,1,3],[ais,b,cis,dis]) + ,([10,11,1],[ais,b,cis]) + ,([10,11,2,3],[bes,ces,d,ees]) + ,([10,11,2],[ais,b,d]) + ,([10,11],[ais,b]) + ,([10],[bes]) + ,([11,0,1,2],[aisis,bis,cis,d]) + ,([11,0,1,3],[b,c,des,ees]) + ,([11,0,1],[b,c,des]) + ,([11,0,2,3],[b,c,d,ees]) + ,([11,0,2],[b,c,d]) + ,([11,0,3],[b,c,dis]) + ,([11,0],[b,c]) + ,([11,1,2,3],[b,cis,d,ees]) + ,([11,1,2],[b,cis,d]) + ,([11,1,3],[b,cis,dis]) + ,([11,1],[b,cis]) + ,([11,2,3],[b,d,ees]) + ,([11,2],[b,d]) + ,([11],[b]) + ,([1],[cis]) + ,([2,3,4,5],[d,ees,fes,geses]) + ,([2,3,4],[d,ees,fes]) + ,([2,3,5],[d,ees,f]) + ,([2,3],[d,ees]) + ,([2,4,5],[d,e,f]) + ,([2,4],[d,e]) + ,([2,5],[d,f]) + ,([2],[d]) + ,([3,4,5],[dis,e,f]) + ,([3,4],[dis,e]) + ,([3,5],[ees,f]) + ,([3],[ees]) + ,([4,5],[e,f]) + ,([4],[e]) + ,([5,6,7,8,9],[eis,fis,g,aes,beses]) + ,([5,6,7,8],[eis,fis,g,aes]) + ,([5,6,7,9],[eis,fis,g,a]) + ,([5,6,7],[eis,fis,g]) + ,([5,6,8,9],[eis,fis,gis,a]) + ,([5,6,8],[f,ges,aes]) + ,([5,6,9],[f,ges,a]) + ,([5,6],[f,ges]) + ,([5,7,8,9],[f,g,aes,beses]) + ,([5,7,8],[f,g,aes]) + ,([5,7,9],[f,g,a]) + ,([5,7],[f,g]) + ,([5,8,9],[f,gis,a]) + ,([5,8],[f,aes]) + ,([5,9],[f,a]) + ,([5],[f]) + ,([6,7,8,9],[fis,g,aes,beses]) + ,([6,7,8],[fis,g,aes]) + ,([6,7,9],[fis,g,a]) + ,([6,7],[fis,g]) + ,([6,8,9],[fis,gis,a]) + ,([6,8],[fis,gis]) + ,([6,9],[fis,a]) + ,([6],[fis]) + ,([7,8,9],[fisis,gis,a]) + ,([7,8],[g,aes]) + ,([7,9],[g,a]) + ,([7],[g]) + ,([8,10],[aes,bes]) + ,([8,9,10],[gis,a,bes]) + ,([8,9],[gis,a]) + ,([8],[aes]) + ,([9,10],[a,bes]) + ,([9],[a])] + +spell_cluster :: [T.PitchClass] -> Maybe [(T.Note_T,T.Alteration_T)] +spell_cluster = flip lookup spell_cluster_table + +-- | Spell an arbitrary sequence of 'T.OctPC' values. +-- +-- > fmap (map T.pitch_pp_iso) (spell_cluster_octpc [(3,11),(4,3),(4,11),(5,1)]) +spell_cluster_octpc :: [T.OctPC] -> Maybe [T.Pitch] +spell_cluster_octpc o = + let p = cluster_normal_order (sort (nub (map snd o))) + na_f na = + let na_tbl = map (\x -> (T.note_alteration_to_pc_err x,x)) na + o_f (oct,pc) = let (n,alt) = T.lookup_err pc na_tbl in T.Pitch n alt oct + in map o_f o + in fmap na_f (spell_cluster p) + -- | 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 +-- > let f = (fmap (map T.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 +-- > fmap (map T.pitch_pp) (spell_cluster_c4 [10,11]) == Just ["A♯4","B4"] +spell_cluster_c4 :: [T.PitchClass] -> Maybe [T.Pitch] +spell_cluster_c4 p = + let o_0 = if cluster_is_multiple_octave p then 3 else 4 + oct = map fst (cluster_normal_order_octpc o_0 p) + in case spell_cluster p of + Nothing -> Nothing + Just na -> Just (map (\((n,alt),o) -> T.Pitch n alt o) (zip na oct)) -- | 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] +-- > fmap (map T.pitch_pp) (spell_cluster_c 3 [11,0]) == Just ["B2","C3"] +-- > fmap (map T.pitch_pp) (spell_cluster_c 3 [10,11]) == Just ["A♯3","B3"] +spell_cluster_c :: T.Octave -> [T.PitchClass] -> Maybe [T.Pitch] spell_cluster_c o = - fmap (map (pitch_edit_octave (+ (o - 4)))) . + fmap (map (T.pitch_edit_octave (+ (o - 4)))) . spell_cluster_c4 -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so @@ -131,27 +178,27 @@ -- > import Data.Maybe -- -- > let {f n = if n >= 11 then 3 else 4 --- > ;g = map pitch_pp .fromJust . spell_cluster_f f +-- > ;g = map T.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 :: (T.PitchClass -> T.Octave) -> [T.PitchClass] -> Maybe [T.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) + l:_ -> let (o,n) = T.pitch_to_octpc l + oct_f = (+ (o_f n - o)) + in (map (T.pitch_edit_octave oct_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] +-- > fmap (map T.pitch_pp) (spell_cluster_left 3 [11,0]) == Just ["B3","C4"] +-- > fmap (map T.pitch_pp) (spell_cluster_left 3 [10,11]) == Just ["A♯3","B3"] +spell_cluster_left :: T.Octave -> [T.PitchClass] -> Maybe [T.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 + l:_ -> let oct_f = (+ (o - T.octave l)) + in map (T.pitch_edit_octave oct_f) r in fmap fn (spell_cluster_c4 p) diff --git a/Music/Theory/Pitch/Spelling/Key.hs b/Music/Theory/Pitch/Spelling/Key.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Spelling/Key.hs @@ -0,0 +1,33 @@ +module Music.Theory.Pitch.Spelling.Key where + +import qualified Music.Theory.Key as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Table as T {- hmt -} + +pcset_spell_implied_key_f :: Integral i => [i] -> Maybe (T.Spelling i) +pcset_spell_implied_key_f x = + case T.implied_fifths T.Major_Mode x of + Nothing -> Nothing + Just n -> if n == 0 + then Just T.pc_spell_natural + else if n < 0 + then Just T.pc_spell_flat + else Just T.pc_spell_sharp + +-- > map pcset_spell_implied_key [[0,1],[4,10],[3,9],[3,11]] +pcset_spell_implied_key :: Integral i => [i] -> Maybe [(T.Note_T, T.Alteration_T)] +pcset_spell_implied_key x = + case pcset_spell_implied_key_f x of + Just f -> Just (map f x) + Nothing -> Nothing + +-- > map octpc_spell_implied_key [[(3,11),(4,1)],[(3,11),(4,10)]] +octpc_spell_implied_key :: [T.OctPC] -> Maybe [T.Pitch] +octpc_spell_implied_key x = + let f o (n,a) = T.Pitch n a o + in fmap (zipWith f (map fst x)) (pcset_spell_implied_key (map snd x)) + +-- > map (fmap (map T.pitch_pp_iso) . midi_spell_implied_key) [[59,61],[59,70]] +midi_spell_implied_key :: [T.Midi] -> Maybe [T.Pitch] +midi_spell_implied_key = octpc_spell_implied_key . map T.midi_to_octpc diff --git a/Music/Theory/Pitch/Spelling/Table.hs b/Music/Theory/Pitch/Spelling/Table.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Spelling/Table.hs @@ -0,0 +1,101 @@ +-- | Simple table based spelling rules for common music notation. +module Music.Theory.Pitch.Spelling.Table where + +import Data.Maybe {- base -} + +import Music.Theory.Pitch {- hmt -} +import Music.Theory.Pitch.Note {- hmt -} + +type Spelling_Table i = [(i,(Note_T,Alteration_T))] + +-- | Spelling table for natural (♮) notes only. +pc_spell_natural_tbl :: Integral i => Spelling_Table i +pc_spell_natural_tbl = + [(0,(C,Natural)) + ,(2,(D,Natural)) + ,(4,(E,Natural)) + ,(5,(F,Natural)) + ,(7,(G,Natural)) + ,(9,(A,Natural)) + ,(11,(B,Natural))] + +-- | Spelling table for sharp (♯) notes only. +pc_spell_sharp_tbl :: Integral i => Spelling_Table i +pc_spell_sharp_tbl = + [(1,(C,Sharp)) + ,(3,(D,Sharp)) + ,(6,(F,Sharp)) + ,(8,(G,Sharp)) + ,(10,(A,Sharp))] + +-- | Spelling table for flat (♭) notes only. +pc_spell_flat_tbl :: Integral i => Spelling_Table i +pc_spell_flat_tbl = + [(1,(D,Flat)) + ,(3,(E,Flat)) + ,(6,(G,Flat)) + ,(8,(A,Flat)) + ,(10,(B,Flat))] + +-- | Spelling table 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/. +pc_spell_ks_tbl :: Integral i => Spelling_Table i +pc_spell_ks_tbl = + [(1,(C,Sharp)) -- 2♯ + ,(3,(E,Flat)) -- 3♭ + ,(6,(F,Sharp)) -- 1♯ + ,(8,(A,Flat)) -- 3♭/3♯ + ,(10,(B,Flat))] -- 1♭ + +pc_spell_tbl :: Integral i => Spelling_Table i -> Spelling i +pc_spell_tbl tbl = fromMaybe (error "pc_spell_tbl") . flip lookup tbl + +-- | Spell using indicated table prepended to and 'pc_spell_natural_tbl' and 'pc_spell_ks_tbl' +pc_spell_tbl_ks :: Integral i => Spelling_Table i -> Spelling i +pc_spell_tbl_ks tbl = pc_spell_tbl (tbl ++ pc_spell_natural_tbl ++ pc_spell_ks_tbl) + +-- | 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 = flip lookup pc_spell_natural_tbl + +-- | 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_spell_tbl pc_spell_natural_tbl + +-- | Lookup 'pc_spell_ks_tbl'. +-- +-- > map pc_spell_ks [6,8] == [(F,Sharp),(A,Flat)] +pc_spell_ks :: Integral i => Spelling i +pc_spell_ks = pc_spell_tbl_ks [] + +-- | 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] +pc_spell_sharp :: Integral i => Spelling i +pc_spell_sharp = pc_spell_tbl (pc_spell_sharp_tbl ++ pc_spell_natural_tbl) + +-- | 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_spell_tbl (pc_spell_flat_tbl ++ pc_spell_natural_tbl) + +octpc_to_pitch_ks :: Integral i => Octave_PitchClass i -> Pitch +octpc_to_pitch_ks = octpc_to_pitch pc_spell_ks + +-- | 'midi_to_pitch' 'T.pc_spell_ks'. +midi_to_pitch_ks :: Integral i => i -> Pitch +midi_to_pitch_ks = midi_to_pitch pc_spell_ks + +fmidi_to_pitch_ks :: (Show n,RealFrac n) => n -> Pitch +fmidi_to_pitch_ks = fmidi_to_pitch_err pc_spell_ks + +midi_detune_to_pitch_ks :: Real c => Midi_Detune' c -> Pitch +midi_detune_to_pitch_ks = midi_detune_to_pitch pc_spell_ks diff --git a/Music/Theory/Random/I_Ching.hs b/Music/Theory/Random/I_Ching.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Random/I_Ching.hs @@ -0,0 +1,192 @@ +{-# Language BinaryLiterals #-} + +module Music.Theory.Random.I_Ching where + +import Control.Monad {- base -} +import Data.Maybe {- base -} +import System.Random {- random -} + +import qualified Music.Theory.Bits as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} + +-- | Line, indicated as sum. +data Line = L6 | L7 | L8 | L9 deriving (Eq,Show) + +{-| (sum={6,7,8,9}, + (yarrow probablity={1,3,5,7}/16, + three-coin probablity={2,6}/16, + name,signification,symbol)) +-} +type Line_Stat = (Line,(Rational,Rational,String,String,String)) + +i_ching_chart :: [Line_Stat] +i_ching_chart = + [(L6,(1/16,2/16,"old yin","yin changing into yang","---x---")) + ,(L8,(7/16,6/16,"young yin","yin unchanging","--- ---")) + ,(L9,(3/16,2/16,"old yang","yang changing into yin","---o---")) + ,(L7,(5/16,6/16,"young yang","yang unchanging","-------"))] + +-- | Lines L6 and L7 are unbroken (since L6 is becoming L7). +line_unbroken :: Line -> Bool +line_unbroken n = n `elem` [L6,L7] + +line_from_bit :: Bool -> Line +line_from_bit b = if b then L7 else L8 + +-- | Seven character ASCII string for line. +line_ascii_pp :: Line -> String +line_ascii_pp n = fromMaybe (error "line_ascii_pp") (fmap T.p5_fifth (lookup n i_ching_chart)) + +-- | Is line (ie. sum) moving (ie. 6 or 9). +line_is_moving :: Line -> Bool +line_is_moving n = n `elem` [L6,L9] + +-- | Old yin (L6) becomes yang (L7), and old yang (L9) becomes yin (L8). +line_complement :: Line -> Maybe Line +line_complement n = + case n of + L6 -> Just L7 + L9 -> Just L8 + _ -> Nothing + +type Hexagram = [Line] + +-- | Hexagrams are drawn upwards. +hexagram_pp :: Hexagram -> String +hexagram_pp = unlines . reverse . map line_ascii_pp + +{- | Sequence of sum values assigned to ascending four bit numbers. + +> import Music.Theory.Bits {- hmt -} +> zip (map (gen_bitseq_pp 4) [0::Int .. 15]) (map line_ascii_pp_err four_coin_sequence) + +-} +four_coin_sequence :: [Line] +four_coin_sequence = + [L6,L9,L9,L9 + ,L7,L7,L7,L7 + ,L7,L8,L8,L8 + ,L8,L8,L8,L8] + +-- | Generate hexagram (ie. sequence of six lines given by sum) using 'four_coin_sequence'. +-- +-- > four_coin_gen_hexagram >>= putStrLn . hexagram_pp +four_coin_gen_hexagram :: IO Hexagram +four_coin_gen_hexagram = fmap (map (four_coin_sequence !!)) (replicateM 6 (randomRIO (0,15))) + +-- | 'any' of 'line_is_moving'. +hexagram_has_complement :: Hexagram -> Bool +hexagram_has_complement = any line_is_moving + +-- | If 'hexagram_has_complement' then derive it. +-- +-- > h <- four_coin_gen_hexagram +-- > putStrLn (hexagram_pp h) +-- > maybe (return ()) (putStrLn . hexagram_pp) (hexagram_complement h) +hexagram_complement :: Hexagram -> Maybe Hexagram +hexagram_complement h = + let f n = fromMaybe n (line_complement n) + in if hexagram_has_complement h then Just (map f h) else Nothing + +-- | Names of hexagrams, in King Wen order. +-- +-- > length hexagram_names == 64 +hexagram_names :: [(String,String)] +hexagram_names = + [("乾","qián") + ,("坤","kūn") + ,("屯","zhūn") + ,("蒙","méng") + ,("需","xū") + ,("訟","sòng") + ,("師","shī") + ,("比","bǐ") + ,("小畜","xiǎo chù") + ,("履","lǚ") + ,("泰","tài") + ,("否","pǐ") + ,("同人","tóng rén") + ,("大有","dà yǒu") + ,("謙","qiān") + ,("豫","yù") + ,("隨","suí") + ,("蠱","gŭ") + ,("臨","lín") + ,("觀","guān") + ,("噬嗑","shì kè") + ,("賁","bì") + ,("剝","bō") + ,("復","fù") + ,("無妄","wú wàng") + ,("大畜","dà chù") + ,("頤","yí") + ,("大過","dà guò") + ,("坎","kǎn") + ,("離","lí") + ,("咸","xián") + ,("恆","héng") + ,("遯","dùn") + ,("大壯","dà zhuàng") + ,("晉","jìn") + ,("明夷","míng yí") + ,("家人","jiā rén") + ,("睽","kuí") + ,("蹇","jiǎn") + ,("解","xiè") + ,("損","sǔn") + ,("益","yì") + ,("夬","guài") + ,("姤","gòu") + ,("萃","cuì") + ,("升","shēng") + ,("困","kùn") + ,("井","jǐng") + ,("革","gé") + ,("鼎","dǐng") + ,("震","zhèn") + ,("艮","gèn") + ,("漸","jiàn") + ,("歸妹","guī mèi") + ,("豐","fēng") + ,("旅","lǚ") + ,("巽","xùn") + ,("兌","duì") + ,("渙","huàn") + ,("節","jié") + ,("中孚","zhōng fú") + ,("小過","xiǎo guò") + ,("既濟","jì jì") + ,("未濟","wèi jì")] + +-- | Unicode hexagram characters, in King Wen order. +-- +-- > import Data.List.Split {- split -} +-- > mapM_ putStrLn (chunksOf 8 hexagram_unicode_sequence) +hexagram_unicode_sequence :: [Char] +hexagram_unicode_sequence = map toEnum [0x4DC0 .. 0x4DFF] + +hexagram_to_binary :: Hexagram -> Int +hexagram_to_binary = T.pack_bitseq . map line_unbroken + +-- > let h = hexagram_from_binary 0b100010 +-- > putStrLn (hexagram_pp h) +-- > gen_bitseq_pp 6 (hexagram_to_binary h) == "100010" +hexagram_from_binary :: Int -> Hexagram +hexagram_from_binary = map line_from_bit . T.gen_bitseq 6 + +-- > import Data.List {- base -} +-- > putStrLn (intersperse ' ' trigram_unicode_sequence) +trigram_unicode_sequence :: [Char] +trigram_unicode_sequence = map toEnum [0x2630 .. 0x2637] + +-- > map p8_third trigram_chart == [7,6,5,4,3,2,1,0] +trigram_chart :: Num i => [(i, Char, i, Char, String, Char, String, Char)] +trigram_chart = + [(1,'☰',0b111,'乾',"qián",'天',"NW",'馬') + ,(2,'☱',0b110,'兌',"duì",'澤',"W",'羊') + ,(3,'☲',0b101,'離',"lí",'火',"S",'雉') + ,(4,'☳',0b100,'震',"zhèn",'雷',"E",'龍') + ,(5,'☴',0b011,'巽',"xùn",'風',"SE",'雞') + ,(6,'☵',0b010,'坎',"kǎn",'水',"N",'豕') + ,(7,'☶',0b001,'艮',"gèn",'山',"NE",'狗') + ,(8,'☷',0b000,'坤',"kūn",'地',"SW",'牛')] diff --git a/Music/Theory/Read.hs b/Music/Theory/Read.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Read.hs @@ -0,0 +1,147 @@ +-- | Read functions. +module Music.Theory.Read where + +import Data.Char {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} +import Numeric {- base -} + +-- | Transform 'ReadS' function into precise 'Read' function. +-- Requires using all the input to produce a single token. The only +-- exception is a singular trailing white space character. +reads_to_read_precise :: ReadS t -> (String -> Maybe t) +reads_to_read_precise f s = + case f s of + [(r,[])] -> Just r + [(r,[c])] -> if isSpace c then Just r else Nothing + _ -> Nothing + +-- | Error variant of 'reads_to_read_precise'. +reads_to_read_precise_err :: String -> ReadS t -> String -> t +reads_to_read_precise_err err f = + fromMaybe (error ("reads_to_read_precise_err:" ++ err)) . + reads_to_read_precise f + +-- | 'reads_to_read_precise' of 'reads'. +-- space character. +read_maybe :: Read a => String -> Maybe a +read_maybe = reads_to_read_precise reads + +-- | Variant of 'read_maybe' with default value. +-- +-- > map (read_def 0) ["2","2:","2\n"] == [2,0,2] +read_def :: Read a => a -> String -> a +read_def x s = maybe x id (read_maybe s) + +-- | Variant of 'read_maybe' that errors on 'Nothing'. +read_err :: Read a => String -> a +read_err s = maybe (error ("read_err: " ++ s)) id (read_maybe s) + +-- | Variant of 'reads' requiring exact match, no trailing white space. +-- +-- > map reads_exact ["1.5","2,5"] == [Just 1.5,Nothing] +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_exact_err :: Read a => String -> String -> a +reads_exact_err err_txt str = + let err = error ("reads: " ++ err_txt ++ ": " ++ str) + in fromMaybe err (reads_exact str) + +-- * Type specific variants + +-- | Allow commas as thousand separators. +-- +-- > let r = [Just 123456,Just 123456,Nothing,Just 123456789] +-- > in map read_integral_allow_commas_maybe ["123456","123,456","1234,56","123,456,789"] +read_integral_allow_commas_maybe :: Read i => String -> Maybe i +read_integral_allow_commas_maybe s = + let c = filter ((== ',') . fst) (zip (reverse s) [0..]) + in if null c + then read_maybe s + else if map snd c `isPrefixOf` [3::Int,7..] + then read_maybe (filter (not . (== ',')) s) + else Nothing + +read_integral_allow_commas_err :: (Integral i,Read i) => String -> i +read_integral_allow_commas_err s = + let err = error ("read_integral_allow_commas: misplaced commas: " ++ s) + in fromMaybe err (read_integral_allow_commas_maybe s) + +read_int_allow_commas :: String -> Int +read_int_allow_commas = read_integral_allow_commas_err + +-- | Read a ratio where the division is given by @/@ instead of @%@ +-- and the integers allow commas. +-- +-- > map read_ratio_with_div_err ["123,456/7","123,456,789"] == [123456/7,123456789] +read_ratio_with_div_err :: (Integral i, Read i) => String -> Ratio i +read_ratio_with_div_err s = + let f = read_integral_allow_commas_err + in case break (== '/') s of + (n,'/':d) -> f n % f d + _ -> read_integral_allow_commas_err s % 1 + +-- | Read 'Ratio', allow commas for thousand separators. +-- +-- > read_ratio_allow_commas_err "327,680" "177,147" == 327680 / 177147 +read_ratio_allow_commas_err :: (Integral i,Read i) => String -> String -> Ratio i +read_ratio_allow_commas_err n d = let f = read_integral_allow_commas_err in f n % f d + +-- | Delete trailing @.@, 'read' fails for @700.@. +delete_trailing_point :: String -> String +delete_trailing_point s = + case reverse s of + '.':s' -> reverse s' + _ -> s + +-- | 'read_err' disallows trailing decimal points. +-- +-- > map read_fractional_allow_trailing_point_err ["123.","123.4"] == [123.0,123.4] +read_fractional_allow_trailing_point_err :: Read n => String -> n +read_fractional_allow_trailing_point_err = read_err . delete_trailing_point + +-- * Plain type specialisations + +-- | Type specialised 'read_maybe'. +-- +-- > map read_maybe_int ["2","2:","2\n"] == [Just 2,Nothing,Just 2] +read_maybe_int :: String -> Maybe Int +read_maybe_int = read_maybe + +-- | Type specialised 'read_err'. +read_int :: String -> Int +read_int = read_err + +-- | Type specialised 'read_maybe'. +read_maybe_double :: String -> Maybe Double +read_maybe_double = read_maybe + +-- | Type specialised 'read_err'. +read_double :: String -> Double +read_double = read_err + +-- | Type specialised 'read_maybe'. +-- +-- > map read_maybe_rational ["1","1%2","1/2"] == [Nothing,Just (1/2),Nothing] +read_maybe_rational :: String -> Maybe Rational +read_maybe_rational = read_maybe + +-- | Type specialised 'read_err'. +-- +-- > read_rational "1%4" +read_rational :: String -> Rational +read_rational = read_err + +-- * Numeric variants + +-- | Error variant of 'readHex'. +-- +-- > read_hex_err "F0B0" == 61616 +read_hex_err :: (Eq n,Num n) => String -> n +read_hex_err = reads_to_read_precise_err "readHex" readHex diff --git a/Music/Theory/Set/List.hs b/Music/Theory/Set/List.hs --- a/Music/Theory/Set/List.hs +++ b/Music/Theory/Set/List.hs @@ -1,15 +1,17 @@ -- | Set operations on lists. module Music.Theory.Set.List where -import Control.Monad -import Data.List +import Control.Monad {- base -} +import Data.List {- base -} import qualified Math.Combinatorics.Multiset as M {- multiset-comb -} --- | Remove duplicate elements with 'nub' and then 'sort'. +import qualified Music.Theory.List as T {- hmt -} + +-- | 'sort' then 'nub'. -- --- > set_l [3,3,3,2,2,1] == [1,2,3] +-- > set [3,3,3,2,2,1] == [1,2,3] set :: (Ord a) => [a] -> [a] -set = sort . nub +set = nub . sort -- | Size of powerset of set of cardinality /n/, ie. @2@ '^' /n/. -- @@ -24,6 +26,12 @@ powerset :: [a] -> [[a]] powerset = filterM (const [True,False]) +-- | Variant where result is sorted and the empty set is not given. +-- +-- > powerset' [1,2,3] == [[1],[2],[3],[1,2],[1,3],[2,3],[1,2,3]] +powerset' :: Ord a => [a] -> [[a]] +powerset' = tail . T.sort_by_two_stage length id . powerset + -- | Two element subsets. -- -- > pairs [1,2,3] == [(1,2),(1,3),(2,3)] @@ -64,9 +72,25 @@ 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 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 "abc" "" == [] + +-} cartesian_product :: [a] -> [b] -> [(a,b)] cartesian_product p q = [(i,j) | i <- p, j <- q] + +-- | List form of n-fold cartesian product. +-- +-- > length (nfold_cartesian_product [[1..13],[1..4]]) == 52 +-- > length (nfold_cartesian_product ["abc","de","fgh"]) == 3 * 2 * 3 +nfold_cartesian_product :: [[a]] -> [[a]] +nfold_cartesian_product l = + case l of + [] -> [] + [_] -> [] + [x,y] -> [[i,j] | i <- x, j <- y] + x:l' -> concatMap (\e -> map (e :) (nfold_cartesian_product l')) x diff --git a/Music/Theory/Show.hs b/Music/Theory/Show.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Show.hs @@ -0,0 +1,2 @@ +-- | Show functions. +module Music.Theory.Show where diff --git a/Music/Theory/String.hs b/Music/Theory/String.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/String.hs @@ -0,0 +1,15 @@ +-- | String functions. +module Music.Theory.String where + +import Data.Char {- base -} + +-- | Remove @\r@. +filter_cr :: String -> String +filter_cr = filter (not . (==) '\r') + +-- | Delete trailing 'Char' where 'isSpace' holds. +-- +-- > delete_trailing_whitespace " str " == " str" +delete_trailing_whitespace :: String -> String +delete_trailing_whitespace = reverse . dropWhile isSpace . reverse + diff --git a/Music/Theory/Tempo_Marking.hs b/Music/Theory/Tempo_Marking.hs --- a/Music/Theory/Tempo_Marking.hs +++ b/Music/Theory/Tempo_Marking.hs @@ -79,7 +79,7 @@ -- | 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 :: 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) diff --git a/Music/Theory/Tiling/Canon.hs b/Music/Theory/Tiling/Canon.hs --- a/Music/Theory/Tiling/Canon.hs +++ b/Music/Theory/Tiling/Canon.hs @@ -1,11 +1,13 @@ module 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 -} +import qualified Control.Monad.Logic as L {- logict -} + +import qualified Music.Theory.List as T {- hmt -} + -- | Sequence. type S = [Int] @@ -85,65 +87,67 @@ 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) + in map f (T.group_on t3_1 e) -- * Construction -- | 'msum' '.' 'map' 'return'. -- -- > observeAll (fromList [1..7]) == [1..7] -fromList :: MonadPlus m => [a] -> m a -fromList = msum . map return +fromList :: L.MonadPlus m => [a] -> m a +fromList = L.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 :: L.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) + L.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'') + L.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] +{- | 't_normal' of 'L.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 + nub . sort . map t_normal . L.observeAll . perfect_tilings_m s m n -- * Display diff --git a/Music/Theory/Time/Bel1990/R.hs b/Music/Theory/Time/Bel1990/R.hs --- a/Music/Theory/Time/Bel1990/R.hs +++ b/Music/Theory/Time/Bel1990/R.hs @@ -11,184 +11,7 @@ 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 _ _ _ _ _ _ _ _ - +For details see . -} module Music.Theory.Time.Bel1990.R where @@ -359,7 +182,7 @@ -- | 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) +lbel_merge = T.merge_on lterm_time -- | Set of unique 'Tempo' at 'L_Bel'. lbel_tempi :: L_Bel a -> [Tempo] @@ -391,14 +214,14 @@ -- | Unique 'Voice's at 'L_Bel'. lbel_voices :: L_Bel a -> [Voice] lbel_voices = - sortBy (compare `on` reverse) . + sortOn 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) + let l = last (T.group_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 @@ -512,7 +335,7 @@ -- -- > P.parse p_nrests "" "3" p_nrests :: P (Bel a) -p_nrests = liftM nrests p_integer +p_nrests = liftM nrests p_non_negative_integer -- | Parse 'Continue' 'Term'. -- @@ -538,40 +361,41 @@ p_char_node :: P (Bel Char) p_char_node = liftM Node p_char_term --- | Parse positive 'Integer'. +-- | Parse non-negative 'Integer'. -- --- > P.parse p_integer "" "3" -p_integer :: P Integer -p_integer = liftM read (P.many1 P.digit) +-- > P.parse p_non_negative_integer "" "3" +p_non_negative_integer :: P Integer +p_non_negative_integer = liftM read (P.many1 P.digit) --- | Parse positive 'Rational'. +-- | Parse non-negative 'Rational'. -- --- > P.parse (p_rational `P.sepBy` (P.char ',')) "" "3%5,2/3" -p_rational :: P Rational -p_rational = do - n <- p_integer +-- > P.parse (p_non_negative_rational `P.sepBy` (P.char ',')) "" "3%5,2/3" +p_non_negative_rational :: P Rational +p_non_negative_rational = do + n <- p_non_negative_integer _ <- P.oneOf "%/" - d <- p_integer + d <- p_non_negative_integer return (n % d) --- | Parse positive 'Double'. +-- | Parse non-negative '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 +-- > P.parse p_non_negative_double "" "3.5" +-- > P.parse (p_non_negative_double `P.sepBy` (P.char ',')) "" "3.5,7.2,1.0" +p_non_negative_double :: P Double +p_non_negative_double = do a <- P.many1 P.digit _ <- P.char '.' b <- P.many1 P.digit return (read (a ++ "." ++ b)) --- | Parse positive number as 'Rational'. +-- | Parse non-negative 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)] +-- > P.parse (p_non_negative_number `P.sepBy` (P.char ',')) "" "7%2,3.5,3" +p_non_negative_number :: P Rational +p_non_negative_number = + P.choice [P.try p_non_negative_rational + ,P.try (liftM toRational p_non_negative_double) + ,P.try (liftM toRational p_non_negative_integer)] -- | Parse 'Mul'. -- @@ -579,7 +403,7 @@ p_mul :: P (Bel a) p_mul = do op <- P.oneOf "*/" - n <- p_number + n <- p_non_negative_number let n' = case op of '*' -> n '/' -> recip n diff --git a/Music/Theory/Time/Notation.hs b/Music/Theory/Time/Notation.hs --- a/Music/Theory/Time/Notation.hs +++ b/Music/Theory/Time/Notation.hs @@ -1,21 +1,67 @@ module Music.Theory.Time.Notation where +import Data.List.Split {- split -} import Text.Printf {- base -} -- | Fractional seconds. type FSEC = Double -- | Minutes, seconds as @(min,sec)@ +type MinSec n = (n,n) + +-- | Type specialised. type MINSEC = (Int,Int) -- | Minutes, seconds, centi-seconds as @(min,sec,csec)@ +type MinCsec n = (n,n,n) + +-- | Type specialised. type MINCSEC = (Int,Int,Int) +-- | 'divMod' by @60@. +-- +-- > sec_to_minsec 123 == (2,3) +sec_to_minsec :: Integral n => n -> MinSec n +sec_to_minsec = flip divMod 60 + +-- | Inverse of 'sec_minsec'. +-- +-- > minsec_to_sec (2,3) == 123 +minsec_to_sec :: Num n => MinSec n -> n +minsec_to_sec (m,s) = m * 60 + s + +minsec_binop :: Integral t => (t -> t -> t) -> MinSec t -> MinSec t -> MinSec t +minsec_binop f p q = sec_to_minsec (f (minsec_to_sec p) (minsec_to_sec q)) + +-- | 'minsec_binop' '-', assumes /q/ precedes /p/. +-- +-- > minsec_sub (2,35) (1,59) == (0,36) +minsec_sub :: Integral n => MinSec n -> MinSec n -> MinSec n +minsec_sub = minsec_binop (-) + +-- | 'minsec_binop' 'subtract', assumes /p/ precedes /q/. +-- +-- > minsec_diff (1,59) (2,35) == (0,36) +minsec_diff :: Integral n => MinSec n -> MinSec n -> MinSec n +minsec_diff = minsec_binop subtract + +-- | 'minsec_binop' '+'. +-- +-- > minsec_add (1,59) (2,35) == (4,34) +minsec_add :: Integral n => MinSec n -> MinSec n -> MinSec n +minsec_add = minsec_binop (+) + +-- | 'foldl' of 'minsec_add' +-- +-- > minsec_sum [(1,59),(2,35),(4,34)] == (9,08) +minsec_sum :: Integral n => [MinSec n] -> MinSec n +minsec_sum = foldl minsec_add (0,0) + -- | 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 +fsec_to_minsec = sec_to_minsec . round -- | 'MINSEC' pretty printer. -- @@ -23,21 +69,59 @@ minsec_pp :: MINSEC -> String minsec_pp (m,s) = printf "%02d:%02d" m s --- | Fractional seconds to @(min,sec,csec)@. +-- * 'MinSec' parser. +minsec_parse :: (Num n,Read n) => String -> MinSec n +minsec_parse x = + case splitOn ":" x of + [m,s] -> (read m,read s) + _ -> error "parse_minsec" + +-- | Fractional seconds to @(min,sec,csec)@, csec value is 'round'ed. -- -- > 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 + (m,s) = sec_to_minsec tm' cs = round ((tm - fromIntegral tm') * 100) in (m,s,cs) +-- | Inverse of 'fsec_mincsec'. +mincsec_to_fsec :: Real n => MinCsec n -> FSEC +mincsec_to_fsec (m,s,cs) = realToFrac m * 60 + realToFrac s + (realToFrac cs / 100) + +-- > map (mincsec_to_csec . fsec_to_mincsec) [1,6+2/3,123.45] == [100,667,12345] +mincsec_to_csec :: Num n => MinCsec n -> n +mincsec_to_csec (m,s,cs) = m * 60 * 100 + s * 100 + cs + +-- | Centi-seconds to 'MinCsec'. +-- +-- > map csec_to_mincsec [123,12345] == [(0,1,23),(2,3,45)] +csec_to_mincsec :: Integral n => n -> MinCsec n +csec_to_mincsec csec = + let (m,cs) = csec `divMod` 6000 + (s,cs') = cs `divMod` 100 + in (m,s,cs') + +-- | 'MINCSEC' pretty printer, concise mode omits centiseconds when zero. +-- +-- > map (mincsec_pp_opt True . fsec_to_mincsec) [1,60.5] == ["00:01","01:00.50"] +mincsec_pp_opt :: Bool -> MINCSEC -> String +mincsec_pp_opt concise (m,s,cs) = + if concise && cs == 0 + then printf "%02d:%02d" m s + else printf "%02d:%02d.%02d" m s cs + -- | 'MINCSEC' pretty printer. -- --- > map (mincsec_pp . fsec_to_mincsec) [1,4/3] == ["00:01.00","00:01.33"] +-- > let r = ["00:01.00","00:06.67","02:03.45"] +-- > map (mincsec_pp . fsec_to_mincsec) [1,6+2/3,123.45] == r mincsec_pp :: MINCSEC -> String -mincsec_pp (m,s,cs) = printf "%02d:%02d.%02d" m s cs +mincsec_pp = mincsec_pp_opt False +mincsec_binop :: Integral t => (t -> t -> t) -> MinCsec t -> MinCsec t -> MinCsec t +mincsec_binop f p q = csec_to_mincsec (f (mincsec_to_csec p) (mincsec_to_csec q)) + +-- | Given printer, pretty print time span. span_pp :: (t -> String) -> (t,t) -> String span_pp f (t1,t2) = concat [f t1," - ",f t2] diff --git a/Music/Theory/Time/Seq.hs b/Music/Theory/Time/Seq.hs --- a/Music/Theory/Time/Seq.hs +++ b/Music/Theory/Time/Seq.hs @@ -6,13 +6,13 @@ 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.Ord as T {- hmt -} import qualified Music.Theory.Tuple as T {- hmt -} -- * Types @@ -26,16 +26,16 @@ -- | 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. +-- a /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/ +-- | Time-point sequence. To express holes /a/ must have an /empty/ -- value. To indicate the duration of the final value /a/ must have --- an /nil/ (end of sequence) value. +-- a /nil/ (end of sequence) value. type Tseq t a = [(t,a)] -- | Window sequence. The temporal field is (/time/,/duration/). @@ -69,6 +69,20 @@ wseq_tspan :: Num t => Wseq t a -> (t,t) wseq_tspan = seq_tspan fst (uncurry (+)) +-- | Start time of sequence. +-- +-- > wseq_start [((1,2),'a')] == 1 +-- > wseq_start [] == 0 +wseq_start :: Num t => Wseq t a -> t +wseq_start = fst . wseq_tspan + +-- | End time of sequence. +-- +-- > wseq_end [((1,2),'a')] == 3 +-- > wseq_end (useq_to_wseq 0 (1,"linear")) == 6 +wseq_end :: Num t => Wseq t a -> t +wseq_end = snd . wseq_tspan + -- * Duration dseq_dur :: Num t => Dseq t a -> t @@ -94,15 +108,52 @@ -- * Window --- | Keep only elements in the indicated temporal window. +-- | Prefix of sequence where the start time precedes or is at the +-- indicate time. +wseq_until :: Ord t => t -> Wseq t a -> Wseq t a +wseq_until tm = takeWhile (\((t0,_),_) -> t0 <= tm) + +-- | Keep only elements that are entirely contained within the indicated +-- temporal window, which is inclusive at the left & right +-- edges, ie. [t0,t1]. Halts processing at end of 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 +-- > in wseq_twindow (5,9) (zip (zip [1..] (repeat 1)) ['a'..]) == r +-- +-- > wseq_twindow (1,2) [((1,1),'a'),((1,2),'b')] == [((1,1),'a')] 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 + in wseq_tfilter f . wseq_until w1 +-- | Select nodes that are active at indicated time, comparison is +-- inclusive at left and exclusive at right. Halts processing at end +-- of window. +-- +-- > let sq = [((1,1),'a'),((1,2),'b')] +-- > in map (wseq_at sq) [1,2] == [sq,[((1,2),'b')]] +-- +-- > wseq_at (zip (zip [1..] (repeat 1)) ['a'..]) 3 == [((3,1),'c')] +wseq_at :: (Num t,Ord t) => Wseq t a -> t -> Wseq t a +wseq_at sq tm = + let sel ((t0,t1),_) = t0 <= tm && tm < (t0 + t1) + end ((t0,_),_) = t0 <= tm + in filter sel (takeWhile end sq) + +-- | Select nodes that are active within the indicated window, comparison is +-- inclusive at left and exclusive at right. Halts processing at end +-- of window. +-- +-- > let sq = [((0,2),'a'),((0,4),'b'),((2,4),'c')] +-- > in wseq_at_window sq (1,3) == sq +-- +-- > wseq_at_window (zip (zip [1..] (repeat 1)) ['a'..]) (3,4) == [((3,1),'c'),((4,1),'d')] +wseq_at_window :: (Num t, Ord t) => Wseq t a -> (t,t) -> Wseq t a +wseq_at_window sq (w0,w1) = + let f (t0,t1) t = t0 <= t && t < t1 + g (st,du) = let w = (st,st + du) in f w w0 || f w w1 + in wseq_tfilter g (wseq_until w1 sq) + -- * Append dseq_append :: Dseq t a -> Dseq t a -> Dseq t a @@ -140,11 +191,24 @@ g (t,p) (_,q) = (t,f p q) in T.merge_by_resolve g cmp +-- | Compare first by start time, then by duration. +w_compare :: Ord t => ((t,t),a) -> ((t,t),a) -> Ordering +w_compare ((t1,d1),_) ((t2,d2),_) = + case compare t1 t2 of + EQ -> compare d1 d2 + r -> r + +-- | Merge considering only start times. wseq_merge :: Ord t => Wseq t a -> Wseq t a -> Wseq t a wseq_merge = O.mergeBy (compare `on` (fst . fst)) +-- | Merge set considering both start times & durations. +wseq_merge_set :: Ord t => [Wseq t a] -> Wseq t a +wseq_merge_set = T.merge_set_by w_compare + -- * Lookup +-- | Locate nodes to the left and right of indicated time. 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 = @@ -276,7 +340,7 @@ 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) . + from_map = sortOn fst . map (\(v,l) -> (v,reverse l)) . M.toList in from_map (foldl assign M.empty sq) @@ -379,6 +443,9 @@ -- -- > let r = [(0,"a"),(1,"bc"),(2,"de"),(3,"f")] -- > in tseq_group (zip [0,1,1,2,2,3] ['a'..]) == r +-- +-- > tseq_group [(1,'a'),(1,'b')] == [(1,"ab")] +-- > tseq_group [(1,'a'),(2,'b'),(2,'c')] == [(1,"a"),(2,"bc")] tseq_group :: (Eq t,Num t) => Tseq t a -> Tseq t [a] tseq_group = group_f (==) @@ -432,35 +499,66 @@ -- * Wseq +-- | Sort 'Wseq' by start time, 'Wseq' ought never to be out of +-- order. +-- +-- > wseq_sort [((3,1),'a'),((1,3),'b')] == [((1,3),'b'),((3,1),'a')] +wseq_sort :: Ord t => Wseq t a -> Wseq t a +wseq_sort = sortBy (compare `on` (fst . fst)) + -- | 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_overlap_f :: (Eq e,Ord t,Num t) => + (e -> e -> Bool) -> (t -> t) -> ((t,t),e) -> Wseq t e -> Maybe (Wseq t e) +wseq_overlap_f eq_fn dur_fn ((t,d),a) sq = + case find (eq_fn a . snd) sq of + Nothing -> Nothing + Just ((t',d'),a') -> + if t == t' + then if d <= d' + then Just sq -- delete LHS + else Just (((t,d),a) : delete ((t',d'),a') sq) -- delete RHS + else if t' < t + d + then Just (((t,dur_fn (t' - t)),a) : sq) -- truncate LHS + else Nothing + +-- | Determine if sequence has overlapping equal nodes. +wseq_has_overlaps :: (Ord t, Num t, Eq e) => (e -> e -> Bool) -> Wseq t e -> Bool +wseq_has_overlaps eq_fn = + let recur sq = + case sq of + [] -> False + h:sq' -> + case wseq_overlap_f eq_fn id h sq' of + Nothing -> recur sq' + Just _ -> True + in recur + + +{- | Edit durations to ensure that nodes don't overlap. If equal nodes + begin simultaneously delete the shorter node. If a node + extends into a later node shorten the initial duration (apply /dur_fn/ to iot). + +> let sq = [((0,1),'a'),((0,5),'a'),((1,5),'a'),((3,1),'a')] +> let r = [((0,1),'a'),((1,2),'a'),((3,1),'a')] +> wseq_has_overlaps (==) sq == True +> wseq_remove_overlaps (==) id sq == r +> wseq_has_overlaps (==) (wseq_remove_overlaps (==) id sq) == False + +-} 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 + (e -> e -> Bool) -> (t -> t) -> Wseq t e -> Wseq t e +wseq_remove_overlaps eq_fn dur_fn = + let recur sq = + case sq of + [] -> [] + h:sq' -> + case wseq_overlap_f eq_fn dur_fn h sq' of + Nothing -> h : recur sq' + Just sq'' -> recur sq'' + in recur -- | Unjoin elements (assign equal time stamps to all elements). seq_unjoin :: [(t,[e])] -> [(t,e)] @@ -470,87 +568,149 @@ wseq_unjoin :: Wseq t [e] -> Wseq t e wseq_unjoin = seq_unjoin --- * On/Off +-- | Shift (displace) onset times by /i/. +-- +-- > wseq_shift 3 [((1,2),'a')] == [((4,2),'a')] +wseq_shift :: Num t => t -> Wseq t a -> Wseq t a +wseq_shift i = wseq_tmap_st (+ i) --- | Container for values that have /on/ and /off/ modes. -data On_Off a = On a | Off a deriving (Eq,Show) +-- | Shift q to end of p and append. +-- +-- > wseq_append [((1,2),'a')] [((1,2),'b')] == [((1,2),'a'),((4,2),'b')] +wseq_append :: Num t => Wseq t a -> Wseq t a -> Wseq t a +wseq_append p q = p ++ wseq_shift (wseq_end p) q --- | 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 = +-- | 'foldl1' of 'wseq_append' +-- +-- > wseq_concat [[((1,2),'a')],[((1,2),'b')]] == [((1,2),'a'),((4,2),'b')] +wseq_concat :: Num t => [Wseq t a] -> Wseq t a +wseq_concat = foldl1 wseq_append + +-- * Begin/End + +-- | Container to mark the /begin/ and /end/ of a value. +data Begin_End a = Begin a | End a deriving (Eq,Show) + +-- | Functor instance. +begin_end_map :: (t -> u) -> Begin_End t -> Begin_End u +begin_end_map f x = + case x of + Begin a -> Begin (f a) + End a -> End (f a) + +-- | Structural comparison at 'Begin_End', 'Begin' compares less than 'End'. +cmp_begin_end :: Begin_End a -> Begin_End b -> Ordering +cmp_begin_end p q = case (p,q) of - (On _,Off _) -> LT - (On _,On _) -> EQ - (Off _,Off _) -> EQ - (Off _,On _) -> GT + (Begin _,End _) -> LT + (Begin _,Begin _) -> EQ + (End _,End _) -> EQ + (End _,Begin _) -> GT -- | Translate container types. -either_to_on_off :: Either a a -> On_Off a -either_to_on_off p = +either_to_begin_end :: Either a a -> Begin_End a +either_to_begin_end p = case p of - Left a -> On a - Right a -> Off a + Left a -> Begin a + Right a -> End a -- | Translate container types. -on_off_to_either :: On_Off a -> Either a a -on_off_to_either p = +begin_end_to_either :: Begin_End a -> Either a a +begin_end_to_either p = case p of - On a -> Left a - Off a -> Right a + Begin a -> Left a + End a -> Right a --- | Convert 'Wseq' to 'Tseq' transforming elements to 'On' and 'Off' --- parts. When merging, /off/ elements precede /on/ elements at equal --- times. +begin_end_partition :: [Begin_End a] -> ([a],[a]) +begin_end_partition = + let f e (p,q) = case e of + Begin x -> (x:p,q) + End x -> (p,x:q) + in foldr f ([],[]) + +-- | Add or delete element from accumulated state. +begin_end_track :: Eq a => [a] -> Begin_End a -> [a] +begin_end_track st e = + case e of + Begin x -> x : st + End x -> delete x st + +-- | Convert 'Wseq' to 'Tseq' transforming elements to 'Begin_End'. +-- When merging, /end/ elements precede /begin/ 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 +-- > ;r = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End 'a')]} +-- > in wseq_begin_end 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)] +-- > ;r = [(0,Begin 'a'),(1,End 'a') +-- > ,(1,Begin 'b'),(2,End 'b') +-- > ,(2,Begin 'c'),(3,End 'c')]} +-- > in wseq_begin_end sq == r +wseq_begin_end :: (Num t, Ord t) => Wseq t a -> Tseq t (Begin_End a) +wseq_begin_end sq = + let f ((t,d),a) = [(t,Begin a),(t + d,End a)] g l = case l of [] -> [] - e:l' -> tseq_merge_by (T.ordering_invert .: cmp_on_off) e (g l') + e:l' -> tseq_merge_by (T.ord_invert .: cmp_begin_end) 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 +-- | 'begin_end_to_either' of 'wseq_begin_end'. +wseq_begin_end_either :: (Num t, Ord t) => Wseq t a -> Tseq t (Either a a) +wseq_begin_end_either = tseq_map begin_end_to_either . wseq_begin_end --- | Variant that applies /on/ and /off/ functions to nodes. +-- | Variant that applies /begin/ and /end/ 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 +-- > in wseq_begin_end_f Data.Char.toUpper id sq == r +wseq_begin_end_f :: (Ord t,Num t) => (a -> b) -> (a -> b) -> Wseq t a -> Tseq t b +wseq_begin_end_f f g = tseq_map (either f g) . wseq_begin_end_either --- | Inverse of 'wseq_on_off' given a predicate function for locating --- the /off/ node of an /on/ node. +-- | Result for each time-point the triple (begin-list,end-list,hold-list). +-- The elements of the end-list have been deleted from the hold list. +tseq_begin_end_accum :: Eq a => Tseq t [Begin_End a] -> Tseq t ([a],[a],[a]) +tseq_begin_end_accum = + let f st (t,x) = + let (b,e) = begin_end_partition x + st' = foldl begin_end_track st x + in (st',(t,(b,e,st \\ e))) + in snd . mapAccumL f [] + +tseq_accumulate :: Eq a => Tseq t [Begin_End a] -> Tseq t [a] +tseq_accumulate = + let f st (t,e) = + let g st' = (st',(t,st')) + in g (foldl begin_end_track st e) + in snd . mapAccumL f [] + +-- | The transition sequence of /active/ elements. -- --- > let {sq = [(0,On 'a'),(2,On 'b'),(4,Off 'b'),(5,Off 'a')] +-- > let w = [((0,3),'a'),((1,2),'b'),((2,1),'c'),((3,3),'d')] +-- > wseq_accumulate w == [(0,"a"),(1,"ba"),(2,"cba"),(3,"d"),(6,"")] +wseq_accumulate :: (Eq a,Ord t,Num t) => Wseq t a -> Tseq t [a] +wseq_accumulate = tseq_accumulate . tseq_group . wseq_begin_end + +-- | Inverse of 'wseq_begin_end' given a predicate function for locating +-- the /end/ node of a /begin/ node. +-- +-- > let {sq = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End '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 = +-- > in tseq_begin_end_to_wseq (==) sq == r +tseq_begin_end_to_wseq :: Num t => (a -> a -> Bool) -> Tseq t (Begin_End a) -> Wseq t a +tseq_begin_end_to_wseq cmp = let cmp' x e = case e of - Off x' -> cmp x x' + End 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?" + Nothing -> error "tseq_begin_end_to_wseq: no matching end?" 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' + (_,End _) : sq' -> go sq' + (t,Begin e) : sq' -> let t' = f e sq' in ((t,t' - t),e) : go sq' in go -- * Interop @@ -558,6 +718,9 @@ useq_to_dseq :: Useq t a -> Dseq t a useq_to_dseq (t,e) = zip (repeat t) e +useq_to_wseq :: Num t => t -> Useq t a -> Wseq t a +useq_to_wseq t0 = dseq_to_wseq t0 . useq_to_dseq + -- | The conversion requires a start time and a /nil/ value used as an -- /eof/ marker. Productive given indefinite input sequence. -- @@ -574,8 +737,8 @@ a' = a ++ [nil] in zip t a' --- | Variant where the /nil/ is take as the last element of the --- sequence. +-- | Variant where the /nil/ value is taken from 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 @@ -595,7 +758,8 @@ 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'. +-- has no duration and is not represented in the 'Dseq'. A 'nil' +-- value is required in case the 'Tseq' does not begin at @0@. -- -- > let r = zip [1,2,3,2,1] "abcde" -- > in tseq_to_dseq undefined (zip [0,1,3,6,8,9] "abcde|") == r @@ -689,6 +853,30 @@ (z',r) = T.dx_d' z tm in (z',zip r el) in mapAccumL f + +-- * Cycle + +wseq_cycle' :: Num t => Wseq t a -> [Wseq t a] +wseq_cycle' sq = + let (_,et) = wseq_tspan sq + t_sq = iterate (+ et) 0 + in map (\x -> wseq_tmap (\(t,d) -> (x + t,d)) sq) t_sq + +-- | Only finite 'Wseq' can be cycled, the resulting Wseq is infinite. +-- +-- > take 5 (wseq_cycle [((0,1),'a'),((3,3),'b')]) +wseq_cycle :: Num t => Wseq t a -> Wseq t a +wseq_cycle = concat . wseq_cycle' + +-- | Variant cycling only /n/ times. +-- +-- > wseq_cycle_n 3 [((0,1),'a'),((3,3),'b')] +wseq_cycle_n :: Num t => Int -> Wseq t a -> Wseq t a +wseq_cycle_n n = concat . take n . wseq_cycle' + +-- | 'wseq_until' of 'wseq_cycle'. +wseq_cycle_until :: (Num t,Ord t) => t -> Wseq t a -> Wseq t a +wseq_cycle_until et = wseq_until et . wseq_cycle -- * Type specialised map diff --git a/Music/Theory/Time_Signature.hs b/Music/Theory/Time_Signature.hs --- a/Music/Theory/Time_Signature.hs +++ b/Music/Theory/Time_Signature.hs @@ -1,6 +1,7 @@ -- | Time Signatures. module Music.Theory.Time_Signature where +import Data.Function {- base -} import Data.Ratio {- base -} import Music.Theory.Duration @@ -37,6 +38,7 @@ (1,1) -> [whole_note] (2,2) -> [whole_note] (4,4) -> [whole_note] + (8,8) -> [whole_note] (5,4) -> [whole_note,quarter_note] (3,2) -> [dotted_whole_note] (6,4) -> [dotted_whole_note] @@ -59,10 +61,14 @@ ts_rq :: Time_Signature -> RQ ts_rq (n,d) = (4 * n) % d +-- | 'compare' 'on' 'ts_rq'. +ts_compare :: Time_Signature -> Time_Signature -> Ordering +ts_compare = compare `on` ts_rq + -- | '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 -> Time_Signature rq_to_ts rq = let n = numerator rq d = denominator rq * 4 @@ -74,6 +80,7 @@ -- > ts_divisions (3,8) == [1/2,1/2,1/2] -- > ts_divisions (2,2) == [2,2] -- > ts_divisions (1,1) == [4] +-- > ts_divisions (7,4) == [1,1,1,1,1,1,1] ts_divisions :: Time_Signature -> [RQ] ts_divisions (i,j) = let k = fromIntegral i diff --git a/Music/Theory/Tuning.hs b/Music/Theory/Tuning.hs --- a/Music/Theory/Tuning.hs +++ b/Music/Theory/Tuning.hs @@ -1,15 +1,19 @@ -- | Tuning theory module Music.Theory.Tuning where -import Data.Fixed {- base -} +import Data.Fixed (mod') {- base -} import Data.List {- base -} +import qualified Data.Map as M {- containers -} 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.Map as T {- hmt -} import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Set.List as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} -- * Types @@ -22,35 +26,38 @@ -- | 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} +-- +-- In both cases, the values are given in relation to the first degree +-- of the scale, which for ratios is 1 and for cents 0. +data Tuning = Tuning {tn_ratios_or_cents :: Either [Rational] [Cents] + ,tn_octave_ratio :: Rational} deriving (Eq,Show) -- | Divisions of octave. -- --- > divisions ditone == 12 -divisions :: Tuning -> Int -divisions = either length length . ratios_or_cents +-- > tn_divisions (equal_temperament 12) == 12 +tn_divisions :: Tuning -> Int +tn_divisions = either length length . tn_ratios_or_cents -- | 'Maybe' exact ratios of 'Tuning'. -ratios :: Tuning -> Maybe [Rational] -ratios = T.fromLeft . ratios_or_cents +tn_ratios :: Tuning -> Maybe [Rational] +tn_ratios = T.fromLeft . tn_ratios_or_cents -- | 'error'ing variant. -ratios_err :: Tuning -> [Rational] -ratios_err = fromMaybe (error "ratios") . ratios +tn_ratios_err :: Tuning -> [Rational] +tn_ratios_err = fromMaybe (error "ratios") . tn_ratios -- | Possibly inexact 'Cents' of tuning. -cents :: Tuning -> [Cents] -cents = either (map ratio_to_cents) id . ratios_or_cents +tn_cents :: Tuning -> [Cents] +tn_cents = either (map ratio_to_cents) id . tn_ratios_or_cents -- | 'map' 'round' '.' 'cents'. -cents_i :: Integral i => Tuning -> [i] -cents_i = map round . cents +tn_cents_i :: Integral i => Tuning -> [i] +tn_cents_i = map round . tn_cents -- | Variant of 'cents' that includes octave at right. -cents_octave :: Tuning -> [Cents] -cents_octave t = cents t ++ [ratio_to_cents (octave_ratio t)] +tn_cents_octave :: Tuning -> [Cents] +tn_cents_octave t = tn_cents t ++ [ratio_to_cents (tn_octave_ratio t)] -- | Convert from interval in cents to frequency ratio. -- @@ -59,30 +66,64 @@ cents_to_ratio n = 2 ** (n / 1200) -- | Possibly inexact 'Approximate_Ratio's of tuning. -approximate_ratios :: Tuning -> [Approximate_Ratio] -approximate_ratios = +tn_approximate_ratios :: Tuning -> [Approximate_Ratio] +tn_approximate_ratios = either (map approximate_ratio) (map cents_to_ratio) . - ratios_or_cents + tn_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) +tn_approximate_ratios_cyclic :: Tuning -> [Approximate_Ratio] +tn_approximate_ratios_cyclic t = + let r = tn_approximate_ratios t + m = realToFrac (tn_octave_ratio t) g = iterate (* m) 1 f n = map (* n) r in concatMap f g +-- | Iterate the function /f/ /n/ times, the inital value is /x/. +-- +-- > recur_n 5 (* 2) 1 == 32 +-- > take (5 + 1) (iterate (* 2) 1) == [1,2,4,8,16,32] +recur_n :: Integral n => n -> (t -> t) -> t -> t +recur_n n f x = if n < 1 then x else recur_n (n - 1) f (f x) + +-- | Convert a (signed) number of octaves difference of given ratio to a ratio. +-- +-- > map (oct_diff_to_ratio 2) [-3 .. 3] == [1/8,1/4,1/2,1,2,4,8] +-- > map (oct_diff_to_ratio (9/8)) [-3 .. 3] == [512/729,64/81,8/9,1/1,9/8,81/64,729/512] +oct_diff_to_ratio :: Integral a => Ratio a -> Int -> Ratio a +oct_diff_to_ratio r n = if n >= 0 then recur_n n (* r) 1 else recur_n (negate n) (/ r) 1 + +-- | Lookup function that allows both negative & multiple octave indices. +-- +-- > let map_zip f l = zip l (map f l) +-- > map_zip (tn_ratios_lookup werckmeister_vi) [-24 .. 24] +tn_ratios_lookup :: Tuning -> Int -> Maybe Rational +tn_ratios_lookup t n = + let (o,pc) = n `divMod` tn_divisions t + o_ratio = oct_diff_to_ratio (tn_octave_ratio t) o + in fmap (\r -> o_ratio * (r !! pc)) (tn_ratios t) + +-- | Lookup function that allows both negative & multiple octave indices. +-- +-- > map_zip (tn_approximate_ratios_lookup werckmeister_v) [-24 .. 24] +tn_approximate_ratios_lookup :: Tuning -> Int -> Approximate_Ratio +tn_approximate_ratios_lookup t n = + let (o,pc) = n `divMod` tn_divisions t + o_ratio = fromRational (oct_diff_to_ratio (tn_octave_ratio t) o) + in o_ratio * ((tn_approximate_ratios t) !! pc) + -- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents' -- of 'Tuning'. -- +-- > :l Music.Theory.Tuning.Werckmeister -- > 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 = +-- > tn_reconstructed_ratios 1e-2 werckmeister_iii == Just r +tn_reconstructed_ratios :: Double -> Tuning -> Maybe [Rational] +tn_reconstructed_ratios epsilon = fmap (map (reconstructed_ratio epsilon)) . T.fromRight . - ratios_or_cents + tn_ratios_or_cents -- | Convert from a 'Floating' ratio to /cents/. -- @@ -100,15 +141,17 @@ approximate_ratio = fromRational -- | 'approximate_ratio_to_cents' '.' 'approximate_ratio'. -ratio_to_cents :: Rational -> Cents -ratio_to_cents = approximate_ratio_to_cents . approximate_ratio +-- +-- > map (\n -> (n,round (ratio_to_cents (fold_ratio_to_octave_err (n % 1))))) [1..21] +ratio_to_cents :: Integral i => Ratio i -> Cents +ratio_to_cents = approximate_ratio_to_cents . realToFrac -- | 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 +-- > ratio_to_cents (442/295) == 699.9976981706735 reconstructed_ratio :: Double -> Cents -> Rational reconstructed_ratio epsilon c = approxRational (cents_to_ratio c) epsilon @@ -197,16 +240,17 @@ equal_temperament_72 :: Tuning equal_temperament_72 = equal_temperament (72::Int) +-- | 96-tone equal temperament. +equal_temperament_96 :: Tuning +equal_temperament_96 = equal_temperament (96::Int) + -- * Harmonic series --- | Raise or lower the frequency /q/ by octaves until it is in the --- octave starting at /p/. +-- | Harmonic series to /n/th partial, with indicated octave. -- --- > 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 17 2 +harmonic_series :: Integer -> Rational -> Tuning +harmonic_series n o = Tuning (Left [1 .. n%1]) o -- | Harmonic series on /n/. harmonic_series_cps :: (Num t, Enum t) => t -> [t] @@ -236,27 +280,44 @@ partial :: (Num a, Enum a) => a -> Int -> a partial f1 k = harmonic_series_cps f1 `at` (k - 1) +fold_ratio_to_octave' :: Integral i => Ratio i -> Ratio i +fold_ratio_to_octave' = + let rec_f n = if n >= 2 then rec_f (n / 2) else if n < 1 then rec_f (n * 2) else n + in rec_f + +-- | Error if input is less than or equal to zero. +-- +-- > map fold_ratio_to_octave_err [2/3,3/4] == [4/3,3/2] +fold_ratio_to_octave_err :: Integral i => Ratio i -> Ratio i +fold_ratio_to_octave_err n = + if n <= 0 + then error "fold_ratio_to_octave" + else fold_ratio_to_octave' n + -- | 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 +-- > map fold_ratio_to_octave [0,1] == [Nothing,Just 1] +fold_ratio_to_octave :: Integral i => Ratio i -> Maybe (Ratio i) +fold_ratio_to_octave n = if n <= 0 then Nothing else Just (fold_ratio_to_octave' n) +-- | Sun of numerator & denominator. +ratio_nd_sum :: Num a => Ratio a -> a +ratio_nd_sum r = numerator r + denominator r + +min_by :: Ord a => (t -> a) -> t -> t -> t +min_by f p q = if f p <= f q then p else q + -- | 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] +-- > map ratio_interval_class [7/6,12/7] == [7/6,7/6] 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)) + let f = fold_ratio_to_octave_err + in min_by ratio_nd_sum (f i) (f (recip i)) -- | Derivative harmonic series, based on /k/th partial of /f1/. -- @@ -267,31 +328,31 @@ -- > 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) + let f0 = T.cps_in_octave_above f1 (partial f1 k) in harmonic_series_cps f0 --- | Harmonic series to /n/th harmonic (folded). +-- | Harmonic series to /n/th harmonic (folded, duplicated removed). -- --- > harmonic_series_folded 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8] +-- > harmonic_series_folded_r 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])) +-- > in map (round . ratio_to_cents) (harmonic_series_folded_r 17) == r +harmonic_series_folded_r :: Integer -> [Rational] +harmonic_series_folded_r n = nub (sort (map fold_ratio_to_octave_err [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 +harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded_r +harmonic_series_folded :: Integer -> Rational -> Tuning +harmonic_series_folded n o = Tuning (Left (harmonic_series_folded_r n)) o + -- | @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 +harmonic_series_folded_21 = harmonic_series_folded 21 2 -- * Cents @@ -362,6 +423,20 @@ -- which may be distant from the note sounded. type Midi_Tuning_F = Int -> T.Midi_Detune +-- | Variant for tunings that are incomplete. +type Sparse_Midi_Tuning_F = Int -> Maybe T.Midi_Detune + +-- | Variant for sparse tunings that require state. +type Sparse_Midi_Tuning_ST_F st = st -> Int -> (st,Maybe T.Midi_Detune) + +-- | Lift 'Midi_Tuning_F' to 'Sparse_Midi_Tuning_F'. +lift_tuning_f :: Midi_Tuning_F -> Sparse_Midi_Tuning_F +lift_tuning_f tn_f = Just . tn_f + +-- | Lift 'Sparse_Midi_Tuning_F' to 'Sparse_Midi_Tuning_ST_F'. +lift_sparse_tuning_f :: Sparse_Midi_Tuning_F -> Sparse_Midi_Tuning_ST_F st +lift_sparse_tuning_f tn_f st k = (st,tn_f k) + -- | (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). @@ -369,27 +444,175 @@ -- | '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] +-- > let f = d12_midi_tuning_f (equal_temperament 12,0,0) +-- > map f [0..127] == zip [0..127] (repeat 0) 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) + dt = zipWith (-) (tn_cents t) [0,100 .. 1200] + in if tn_divisions t /= 12 + then error "d12_midi_tuning_f: not d12" + else case dt `atMay` pc of + Nothing -> error "d12_midi_tuning_f: pc?" + Just c -> (n,c + c_diff) --- | (t,f0,k) where t=tuning, f0=fundamental frequency, k=midi note --- number for f0, n=gamut +-- | (t,f0,k,g) where t=tuning, f0=fundamental frequency, k=midi note +-- number for f0, g=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 +-- | 'Midi_Tuning_F' for 'CPS_Midi_Tuning'. The function is sparse, it is only +-- valid for /g/ values from /k/. +-- +-- > let f = cps_midi_tuning_f (equal_temperament 72,T.midi_to_cps 59,59,72 * 4) +-- > map f [59 .. 59 + 72] +cps_midi_tuning_f :: CPS_Midi_Tuning -> Sparse_Midi_Tuning_F cps_midi_tuning_f (t,f0,k,g) n = - let r = approximate_ratios_cyclic t + let r = tn_approximate_ratios_cyclic t m = take g (map (T.cps_to_midi_detune . (* f0)) r) - in m `at` (n - k) + in m `atMay` (n - k) --- Local Variables: --- truncate-lines:t --- End: +-- * Midi tuning tables. + +-- | Midi-note-number -> CPS table, possibly sparse. +type MNN_CPS_Table = [(Int,Double)] + +-- | Generates 'MNN_CPS_Table' given 'Midi_Tuning_F' with keys for all valid @MNN@. +-- +-- > import Sound.SC3.Plot +-- > plot_p2_ln [map (fmap round) (gen_cps_tuning_tbl f)] +gen_cps_tuning_tbl :: Sparse_Midi_Tuning_F -> MNN_CPS_Table +gen_cps_tuning_tbl tn_f = + let f n = case tn_f n of + Just r -> Just (n,T.midi_detune_to_cps r) + Nothing -> Nothing + in mapMaybe f [0 .. 127] + +-- * Derived (secondary) tuning table (DTT) lookup. + +-- | Given an 'MNN_CPS_Table' /tbl/, a list of @CPS@ /c/, and a @MNN@ /m/ +-- find the @CPS@ in /c/ that is nearest to the @CPS@ in /t/ for /m/. +dtt_lookup :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (Maybe v,Maybe v) +dtt_lookup tbl cps n = + let f = lookup n tbl + in (f,fmap (T.find_nearest_err cps) f) + +-- | Require table be non-sparse. +dtt_lookup_err :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (k,v,v) +dtt_lookup_err tbl cps n = + case dtt_lookup tbl cps n of + (Just f,Just g) -> (n,f,g) + _ -> error "dtt_lookup" + +-- | Given two tuning tables generate the @dtt@ table. +gen_dtt_lookup_tbl :: MNN_CPS_Table -> MNN_CPS_Table -> MNN_CPS_Table +gen_dtt_lookup_tbl t0 t1 = + let ix = [0..127] + cps = sort (map (T.p3_third . dtt_lookup_err t0 (map snd t1)) ix) + in zip ix cps + +gen_dtt_lookup_f :: MNN_CPS_Table -> MNN_CPS_Table -> Midi_Tuning_F +gen_dtt_lookup_f t0 t1 = + let m = M.fromList (gen_dtt_lookup_tbl t0 t1) + in T.cps_to_midi_detune . T.map_ix_err m + +-- * Euler-Fokker genus + +-- | Normal form, value with occurences count (ie. exponent in notation above). +type EFG i = [(i,Int)] + +-- | Degree of EFG, ie. sum of exponents. +-- +-- > efg_degree [(3,3),(7,2)] == 3 + 2 +efg_degree :: EFG i -> Int +efg_degree = sum . map snd + +-- | Number of tones of EFG, ie. product of increment of exponents. +-- +-- > efg_tones [(3,3),(7,2)] == (3 + 1) * (2 + 1) +efg_tones :: EFG i -> Int +efg_tones = product . map ((+ 1) . snd) + +-- | Collate a genus given as a multiset into standard form, ie. histogram. +-- +-- > efg_collate [3,3,3,7,7] == [(3,3),(7,2)] +efg_collate :: Ord i => [i] -> EFG i +efg_collate = T.histogram . sort + +{- | Factors of EFG given with co-ordinate of grid location. + +> efg_factors [(3,3)] + +> let r = [([0,0],[]),([0,1],[7]),([0,2],[7,7]) +> ,([1,0],[3]),([1,1],[3,7]),([1,2],[3,7,7]) +> ,([2,0],[3,3]),([2,1],[3,3,7]),([2,2],[3,3,7,7]) +> ,([3,0],[3,3,3]),([3,1],[3,3,3,7]),([3,2],[3,3,3,7,7])] +> in efg_factors [(3,3),(7,2)] == r + +-} +efg_factors :: EFG i -> [([Int],[i])] +efg_factors efg = + let k = map (\(_,n) -> [0 .. n]) efg + k' = if length efg == 1 + then concatMap (map return) k + else T.nfold_cartesian_product k + z = map fst efg + f ix = (ix,concat (zipWith (\n m -> replicate n (z !! m)) ix [0..])) + in map f k' + +{- | Ratios of EFG, taking /n/ as the 1:1 ratio, with indices, folded into one octave. + +> let r = sort $ map snd $ efg_ratios 7 [(3,3),(7,2)] +> r == [1/1,9/8,8/7,9/7,21/16,189/128,3/2,27/16,12/7,7/4,27/14,63/32] +> map (round . ratio_to_cents) r == [0,204,231,435,471,675,702,906,933,969,1137,1173] + + 0: 1/1 C 0.000 cents + 1: 9/8 D 203.910 cents + 2: 8/7 D+ 231.174 cents + 3: 9/7 E+ 435.084 cents + 4: 21/16 F- 470.781 cents + 5: 189/128 G- 674.691 cents + 6: 3/2 G 701.955 cents + 7: 27/16 A 905.865 cents + 8: 12/7 A+ 933.129 cents + 9: 7/4 Bb- 968.826 cents + 10: 27/14 B+ 1137.039 cents + 11: 63/32 C- 1172.736 cents + 12: 2/1 C 1200.000 cents + +> let r' = sort $ map snd $ efg_ratios 5 [(5,2),(7,3)] +> r' == [1/1,343/320,35/32,49/40,5/4,343/256,7/5,49/32,8/5,1715/1024,7/4,245/128] +> map (round . ratio_to_cents) r' == [0,120,155,351,386,506,583,738,814,893,969,1124] + +> let r'' = sort $ map snd $ efg_ratios 3 [(3,1),(5,1),(7,1)] +> r'' == [1/1,35/32,7/6,5/4,4/3,35/24,5/3,7/4] +> map (round . ratio_to_cents) r'' == [0,155,267,386,498,653,884,969] + +> let c0 = [0,204,231,435,471,675,702,906,933,969,1137,1173,1200] +> let c1 = [0,120,155,351,386,506,583,738,814,893,969,1124,1200] +> let c2 = [0,155,267,386,498,653,884,969,1200] +> let f (c',y) = map (\x -> (x,y,x,y + 10)) c' +> map f (zip [c0,c1,c2] [0,20,40]) + +-} +efg_ratios :: Real r => Rational -> EFG r -> [([Int],Rational)] +efg_ratios n = + let to_r = fold_ratio_to_octave_err . (/ n) . toRational . product + f (ix,i) = (ix,to_r i) + in map f . efg_factors + +{- | Generate a line drawing, as a set of (x0,y0,x1,y1) 4-tuples. + h=row height, m=distance of vertical mark from row edge, k=distance between rows + +> let e = [[3,3,3],[3,3,5],[3,5,5],[3,5,7],[3,7,7],[5,5,5],[5,5,7],[3,3,7],[5,7,7],[7,7,7]] +> let e = [[3,3,3],[5,5,5],[7,7,7],[3,3,5],[3,5,5],[5,5,7],[5,7,7],[3,7,7],[3,3,7],[3,5,7]] +> let e' = map efg_collate e +> efg_diagram_set (round,25,4,75) e' + +-} +efg_diagram_set :: (Enum n,Real n) => (Cents -> n,n,n,n) -> [EFG n] -> [(n,n,n,n)] +efg_diagram_set (to_f,h,m,k) e = + let f = (++ [1200]) . sort . map (to_f . ratio_to_cents . snd) . efg_ratios 1 + g (c,y) = let y' = y + h + b = [(0,y,1200,y),(0,y',1200,y')] + in b ++ map (\x -> (x,y + m,x,y' - m)) c + in concatMap g (zip (map f e) [0,k ..]) diff --git a/Music/Theory/Tuning/Alves.hs b/Music/Theory/Tuning/Alves.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Alves.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | 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 diff --git a/Music/Theory/Tuning/Alves_1997.hs b/Music/Theory/Tuning/Alves_1997.hs --- a/Music/Theory/Tuning/Alves_1997.hs +++ b/Music/Theory/Tuning/Alves_1997.hs @@ -13,6 +13,9 @@ -- | HMC /slendro/ tuning. -- -- > cents_i alves_slendro == [0,231,498,765,996] +-- +-- > scl <- scl_load "slendro_alves" +-- > cents_i (scale_tuning 0.01 scl) == cents_i alves_slendro alves_slendro :: Tuning alves_slendro = Tuning (Left alves_slendro_r) 2 @@ -24,6 +27,9 @@ -- | HMC /pelog bem/ tuning. -- -- > cents_i alves_pelog_bem == [0,231,316,702,814] +-- +-- > scl <- scl_load "pelog_alves" +-- > cents_i (scale_tuning 0.01 scl) == [0,231,316,471,702,814,969] alves_pelog_bem :: Tuning alves_pelog_bem = Tuning (Left alves_pelog_bem_r) 2 @@ -32,7 +38,7 @@ 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. +-- | HMC /pelog barang/ tuning. -- -- > cents_i alves_pelog_barang == [0,386,471,857,969] alves_pelog_barang :: Tuning @@ -43,7 +49,7 @@ alves_pelog_23467_r :: [Rational] alves_pelog_23467_r = [1,5/4,21/16,3/2,7/4] --- | HMC /pelog barang/ tuning. +-- | HMC /pelog 2,3,4,6,7/ tuning. -- -- > cents_i alves_pelog_23467 == [0,386,471,702,969] alves_pelog_23467 :: Tuning diff --git a/Music/Theory/Tuning/DB.hs b/Music/Theory/Tuning/DB.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/DB.hs @@ -0,0 +1,62 @@ +-- | DB of locally defined tunings, but for ordinary use see "Music.Theory.Tuning.Scala". +module Music.Theory.Tuning.DB where + +import Data.List {- base -} + +import Music.Theory.Tuning + +import Music.Theory.Tuning.Alves_1997 +import Music.Theory.Tuning.Gann_1993 +import Music.Theory.Tuning.Polansky_1978 +import Music.Theory.Tuning.Polansky_1985c + +import Music.Theory.Tuning.DB.Alves +import Music.Theory.Tuning.DB.Gann +import Music.Theory.Tuning.DB.Microtonal_Synthesis +import Music.Theory.Tuning.DB.Riley +import Music.Theory.Tuning.DB.Werckmeister + +-- | (last-name,first-name,title,year,hmt/tuning,scala/name) +type Named_Tuning = (String,String,String,String,Tuning,String) + +named_tuning_t :: Named_Tuning -> Tuning +named_tuning_t (_,_,_,_,t,_) = t + +tuning_db :: [Named_Tuning] +tuning_db = + [("Aaron","Pietro","","1523",pietro_aaron_1523,"meanquar") + ,("Alves","Bill","Slendro","",alves_slendro,"slendro_alves") + ,("Alves","Bill","Pelog/Bem","",alves_pelog_bem,"") + ,("Alves","Bill","Pelog/Barang","",alves_pelog_barang,"") + ,("Gann","Kyle","Superparticular","1992",gann_superparticular,"gann_super") + ,("Harrison","Lou","Ditone","",harrison_ditone,"") + ,("Harrison","Lou","16-tone","",lou_harrison_16,"harrison_16") + ,("Johnston","Ben","MTP","1977",ben_johnston_mtp_1977,"") + ,("Johnston","Ben","25-tone","",ben_johnston_25,"johnston_25") + ,("Kirnberger","Johann Philipp","III","",kirnberger_iii,"kirnberger") + ,("Malcolm","Alexander","Monochord","1721",five_limit_tuning,"malcolm") + ,("Partch","Harry","43-tone","",partch_43,"partch_43") + ,("Polansky","Larry","Piano Study #5","1985",ps5_jpr,"polansky_ps") + ,("Polansky","Larry","Psaltery","1978",psaltery_o,"") + ,("Riley","Terry","Harp of New Albion","",riley_albion,"riley_albion") + ,("Tsuda","Mayumi","13-limit","",mayumi_tsuda,"tsuda13") + ,("Vallotti","","","1754",vallotti,"vallotti") + ,("Werckmeister","Andreas","Werckmeister III","",werckmeister_iii,"werck3") + ,("Werckmeister","Andreas","Werckmeister IV","",werckmeister_iv,"werck4") + ,("Werckmeister","Andreas","Werckmeister V","",werckmeister_v,"werck5") + ,("Werckmeister","Andreas","Werckmeister VI","",werckmeister_vi,"werck6") + ,("Young","La Monte","The Well-Tuned Piano","",lmy_wtp,"young-lm_piano") + ,("Young","Thomas","","1799",thomas_young_1799,"young2") + ,("Zarlino","Gioseffo","","1588",zarlino_1588,"zarlino2") + ,("","","JI/12 7-limit","",septimal_tritone_just_intonation,"ji_12") + ,("","","ET/12","",equal_temperament_12,"") + ,("","","ET/19","",equal_temperament_19,"") + ,("","","ET/31","",equal_temperament_31,"") + ,("","","ET/53","",equal_temperament_53,"") + ,("","","ET/72","",equal_temperament_72,"") + ,("","","ET/96","",equal_temperament_96,"") + ,("","","Pythagorean/12","",pythagorean_12,"pyth_12") + ] + +tuning_db_lookup_scl :: String -> Maybe Tuning +tuning_db_lookup_scl nm = fmap named_tuning_t (find (\(_,_,_,_,_,scl) -> scl == nm) tuning_db) diff --git a/Music/Theory/Tuning/DB/Alves.hs b/Music/Theory/Tuning/DB/Alves.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/DB/Alves.hs @@ -0,0 +1,26 @@ +-- | Bill Alves. +module Music.Theory.Tuning.DB.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 +-- +-- > tn_divisions harrison_ditone == 12 +-- > tn_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 diff --git a/Music/Theory/Tuning/DB/Gann.hs b/Music/Theory/Tuning/DB/Gann.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/DB/Gann.hs @@ -0,0 +1,130 @@ +-- | Kyle Gann. +module Music.Theory.Tuning.DB.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 +-- +-- > map ((+ 60) . (/ 100)) pietro_aaron_1523_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] +-- +-- > import Music.Theory.Tuning.Scala +-- > scl <- scl_load "meanquar" +-- > cents_i (scale_tuning 0.01 scl) == [0,76,193,310,386,503,579,697,773,890,1007,1083] +pietro_aaron_1523 :: Tuning +pietro_aaron_1523 = Tuning (Right pietro_aaron_1523_c) 2 + +-- | 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] +-- +-- > scl <- scl_load "young2" +-- > cents_i (scale_tuning 0.01 scl) == cents_i thomas_young_1799 +thomas_young_1799 :: Tuning +thomas_young_1799 = Tuning (Right thomas_young_1799_c) 2 + +-- | Ratios for 'zarlino'. +-- +-- > length zarlino_1588_r == 16 +zarlino_1588_r :: [Rational] +zarlino_1588_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_1588 == 16 +-- > cents_i zarlino_1588 == [0,71,182,204,294,316,386,498,569,590,702,773,884,996,1018,1088] +-- +-- > scl <- scl_load "zarlino2" +-- > cents_i (scale_tuning 0.01 scl) == cents_i zarlino_1588 +zarlino_1588 :: Tuning +zarlino_1588 = Tuning (Left zarlino_1588_r) 2 + +-- * 20th Century + +-- | Ratios for 'ben_johnston_mtp_1977'. +-- +-- > let c = [0,105,204,298,386,471,551,702,841,906,969,1088] +-- > in map (round . ratio_to_cents) ben_johnston_mtp_1977_r == c +ben_johnston_mtp_1977_r :: [Rational] +ben_johnston_mtp_1977_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_mtp_1977 == [0,105,204,298,386,471,551,702,841,906,969,1088] +ben_johnston_mtp_1977 :: Tuning +ben_johnston_mtp_1977 = Tuning (Left ben_johnston_mtp_1977_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 +-- +-- > scl <- scl_load "gann_super" +-- > cents_i (scale_tuning 0.01 scl) == cents_i gann_superparticular +gann_superparticular :: Tuning +gann_superparticular = Tuning (Left gann_superparticular_r) 2 diff --git a/Music/Theory/Tuning/DB/Microtonal_Synthesis.hs b/Music/Theory/Tuning/DB/Microtonal_Synthesis.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/DB/Microtonal_Synthesis.hs @@ -0,0 +1,230 @@ +-- | +module Music.Theory.Tuning.DB.Microtonal_Synthesis where + +import Music.Theory.Tuning {- hmt -} + +-- | Ratios for 'pythagorean'. +pythagorean_12_r :: [Rational] +pythagorean_12_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] + +-- | Pythagorean tuning, . +-- +-- > cents_i pythagorean_12 == [0,114,204,294,408,498,612,702,816,906,996,1110] +-- +-- > scl <- scl_load "pyth_12" +-- > cents_i (scale_tuning 0.1 scl) == cents_i pythagorean_12 +pythagorean_12 :: Tuning +pythagorean_12 = Tuning (Left pythagorean_12_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), Alexander Malcolm's Monochord (1721). +-- +-- > cents_i five_limit_tuning == [0,112,204,316,386,498,590,702,814,884,996,1088] +-- +-- > scl <- scl_load "malcolm" +-- > cents_i (scale_tuning 0.1 scl) == cents_i five_limit_tuning +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 +-- +-- +-- > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088] +-- > in cents_i septimal_tritone_just_intonation == c +-- +-- > scl <- scl_load "ji_12" +-- > cents_i (scale_tuning 0.1 scl) == cents_i septimal_tritone_just_intonation +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] +-- +-- > scl <- scl_load "kirnberger" +-- > cents_i (scale_tuning 0.1 scl) == cents_i kirnberger_iii +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] +-- +-- > scl <- scl_load "vallotti" +-- > cents_i (scale_tuning 0.1 scl) == cents_i vallotti +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_tsuda == c +mayumi_tsuda_r :: [Rational] +mayumi_tsuda_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 Tsuda 13-limit Just Intonation scale, +-- . +-- +-- > cents_i mayumi_tsuda == [0,128,139,359,454,563,637,746,841,911,1072,1183] +-- +-- > scl <- scl_load "tsuda13" +-- > cents_i (scale_tuning 0.1 scl) == cents_i mayumi_tsuda +mayumi_tsuda :: Tuning +mayumi_tsuda = Tuning (Left mayumi_tsuda_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 +-- +-- > import Music.Theory.Tuning.Scala +-- > scl <- scl_load "harrison_16" +-- > cents_i (scale_tuning 0.1 scl) == cents_i lou_harrison_16 +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] +-- +-- > scl <- scl_load "partch_43" +-- > cents_i (scale_tuning 0.1 scl) == cents_i partch_43 +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 +-- +-- +-- > scl <- scl_load "johnston_25" +-- > cents_i (scale_tuning 0.1 scl) == cents_i ben_johnston_25 +ben_johnston_25 :: Tuning +ben_johnston_25 = Tuning (Left ben_johnston_25_r) 2 diff --git a/Music/Theory/Tuning/DB/Riley.hs b/Music/Theory/Tuning/DB/Riley.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/DB/Riley.hs @@ -0,0 +1,22 @@ +-- | Terry Riley. +module Music.Theory.Tuning.DB.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] +-- +-- > import Music.Theory.Tuning.Scala +-- > scl <- scl_load "riley_albion" +-- > cents_i (scale_tuning 0.01 scl) == cents_i riley_albion +riley_albion :: Tuning +riley_albion = Tuning (Left riley_albion_r) 2 diff --git a/Music/Theory/Tuning/DB/Werckmeister.hs b/Music/Theory/Tuning/DB/Werckmeister.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/DB/Werckmeister.hs @@ -0,0 +1,117 @@ +-- | Andreas Werckmeister (1645-1706). +module Music.Theory.Tuning.DB.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] +-- +-- > import Music.Theory.Tuning.Scala +-- > scl <- scl_load "werck3" +-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iii +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] +-- +-- > scl <- scl_load "werck4" +-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iv +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] +-- +-- > scl <- scl_load "werck5" +-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_v +werckmeister_v :: Tuning +werckmeister_v = Tuning (Right werckmeister_v_c) 2 + +-- | Ratios for 'werckmeister_vi', with supposed correction of 28/25 to 49/44. +-- +-- > let c = [0,91,186,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 + ,49/44 {- 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,186,298,395,498,595,698,793,893,1000,1097] +-- +-- > scl <- scl_load "werck6" +-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_vi +werckmeister_vi :: Tuning +werckmeister_vi = Tuning (Left werckmeister_vi_r) 2 diff --git a/Music/Theory/Tuning/ET.hs b/Music/Theory/Tuning/ET.hs --- a/Music/Theory/Tuning/ET.hs +++ b/Music/Theory/Tuning/ET.hs @@ -6,46 +6,59 @@ import Data.Ratio {- base -} import Text.Printf {- base -} -import Music.Theory.List {- hmt -} +import qualified Music.Theory.List as T {- hmt -} import Music.Theory.Pitch {- hmt -} import Music.Theory.Pitch.Note {- hmt -} -import Music.Theory.Pitch.Spelling {- hmt -} +import Music.Theory.Pitch.Spelling.Table {- hmt -} import Music.Theory.Tuning {- hmt -} -- | 'octpc_to_pitch' and 'octpc_to_cps'. +octpc_to_pitch_cps_f0 :: (Floating n) => n -> OctPC -> (Pitch,n) +octpc_to_pitch_cps_f0 f0 x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps_f0 f0 x) + +-- | '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) +octpc_to_pitch_cps = octpc_to_pitch_cps_f0 440 -- | 12-tone equal temperament table equating 'Pitch' and frequency --- over range of human hearing, where @A4@ = @440@hz. +-- over range of human hearing, where @A4@ has given frequency. -- +-- > tbl_12et_f0 415 +tbl_12et_f0 :: Double -> [(Pitch,Double)] +tbl_12et_f0 f0 = + let z = [(o,pc) | o <- [0..10], pc <- [0..11]] + in map (octpc_to_pitch_cps_f0 f0) z + +-- | 'tbl_12et_f0' @440@hz. +-- -- > length tbl_12et == 132 --- > let min_max l = (minimum l,maximum l) --- > min_max (map (round . snd) tbl_12et) == (16,31609) +-- > minmax (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 +tbl_12et = tbl_12et_f0 440 --- | 24-tone equal temperament variant of 'tbl_12et'. +-- | 24-tone equal temperament variant of 'tbl_12et_f0'. +tbl_24et_f0 :: Double -> [(Pitch,Double)] +tbl_24et_f0 f0 = + let f x = let p = fmidi_to_pitch_err pc_spell_ks x + p' = pitch_rewrite_threequarter_alteration p + in (p',fmidi_to_cps_f0 f0 x) + in map f [12,12.5 .. 143.5] + +-- | 'tbl_24et_f0' @440@. -- -- > length tbl_24et == 264 --- > min_max (map (round . snd) tbl_24et) == (16,32535) +-- > minmax (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] +tbl_24et = tbl_24et_f0 440 -- | Given an @ET@ table (or like) find bounds of frequency. -- --- > let r = Just (at_pair octpc_to_pitch_cps ((3,11),(4,0))) +-- import qualified Music.Theory.Tuple as T +-- +-- > let r = Just (T.t2_map 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 = T.find_bounds True (compare . snd) -- | 'bounds_et_table' of 'tbl_12et'. -- @@ -55,6 +68,8 @@ -- | Tuple indicating nearest 'Pitch' to /frequency/ with @ET@ -- frequency, and deviation in hertz and 'Cents'. +-- +-- (cps,nearest-pitch,cps-of-nearest-pitch,cps-deviation,cents-deviation) type HS_R p = (Double,p,Double,Double,Cents) -- | /n/-decimal places. @@ -76,12 +91,14 @@ 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 +{- | 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 @@ -138,7 +155,7 @@ -- > 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 :: (Int,Int) -> (Pitch_R,Double) pitch_72et (x,n) = let p = midi_to_pitch pc_spell_ks x t = note p @@ -150,7 +167,7 @@ _ -> 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 = (Pitch_R 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) @@ -165,7 +182,7 @@ -- -- > length tbl_72et == 792 -- > min_max (map (round . snd) tbl_72et) == (16,33167) -tbl_72et :: [(Pitch',Double)] +tbl_72et :: [(Pitch_R,Double)] tbl_72et = let f n = map pitch_72et (zip (replicate 6 n) [0..5]) in concatMap f [12 .. 143] @@ -177,7 +194,7 @@ -- -- > 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 :: Double -> HS_R Pitch_R nearest_72et_tone = nearest_et_table_tone tbl_72et -- * Detune @@ -185,7 +202,7 @@ -- | 'Pitch' with 12-ET/24-ET tuning deviation given in 'Cents'. type Pitch_Detune = (Pitch,Cents) --- | Exract 'Pitch_Detune' from 'HS_R'. +-- | Extract 'Pitch_Detune' from 'HS_R'. hsr_to_pitch_detune :: HS_R Pitch -> Pitch_Detune hsr_to_pitch_detune (_,p,_,_,c) = (p,c) @@ -223,26 +240,20 @@ 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) +pitch_detune_in_octave_nearest p1 (p2,d2) = (pitch_in_octave_nearest p1 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) +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) +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) +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) +pitch_class_detune_html (p,c) = pitch_class_pp p ++ cents_diff_html (round c :: Integer) diff --git a/Music/Theory/Tuning/Euler.hs b/Music/Theory/Tuning/Euler.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Euler.hs @@ -0,0 +1,138 @@ +-- | Euler plane diagrams as /dot/ language graph. +module Music.Theory.Tuning.Euler where + +import Data.List {- base -} +import Data.Ratio {- base -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Math as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} + +-- | 'T.fold_ratio_to_octave' of '*'. +rat_mul :: Rational -> Rational -> Rational +rat_mul r = T.fold_ratio_to_octave_err . (* r) + +-- | 'T.fold_ratio_to_octave' of '/'. +rat_div :: Rational -> Rational -> Rational +rat_div p q = T.fold_ratio_to_octave_err (p / q) + +-- | /n/ = length, /m/ equals multiplier, /r/ = initial ratio. +-- +-- > tun_seq 5 (3/2) 1 == [1/1,3/2,9/8,27/16,81/64] +tun_seq :: Int -> Rational -> Rational -> [Rational] +tun_seq n m = take n . iterate (rat_mul m) + +mod12 :: Integral a => a -> a +mod12 n = n `mod` 12 + +-- | 'T.ratio_to_cents' rounded to nearest multiple of 100, modulo 12. +-- +-- > map (ratio_to_pc 0) [1,4/3,3/2,2] == [0,5,7,0] +ratio_to_pc :: Int -> Rational -> Int +ratio_to_pc n = mod12 . (+ n) . round . (/ 100) . T.ratio_to_cents + +all_pairs :: [t] -> [u] -> [(t,u)] +all_pairs p q = [(x,y) | x <- p, y <- q] + +-- | Give all pairs from (l2,l1) and (l3,l2) that are at interval ratios r1 and r2 respectively. +euler_align_rat :: T.T2 Rational -> T.T3 [Rational] -> T.T2 [T.T2 Rational] +euler_align_rat (r1,r2) (l1,l2,l3) = + let f r (p,q) = rat_mul p r == q + in (filter (f r1) (all_pairs l2 l1) + ,filter (f r2) (all_pairs l3 l2)) + +-- | Pretty printer for pitch class. +-- +-- > unwords (map pc_pp [0..11]) == "C♮ C♯ D♮ E♭ E♮ F♮ F♯ G♮ A♭ A♮ B♭ B♮" +pc_pp :: (Integral i,Show i) => i -> String +pc_pp x = + case T.pc_to_note_alteration_ks x of + Just (n,a) -> [T.note_pp n,T.alteration_symbol a] + Nothing -> error (show ("pc_pp",x)) + +cents_pp :: Rational -> String +cents_pp = show . (round :: Double -> Integer) . T.ratio_to_cents + +-- > rat_label (0,False) 1 == "C♮\\n1:1" +-- > rat_label (3,True) (7/4) == "C♯=969\\n7:4" +rat_label :: (Int,Bool) -> Rational -> String +rat_label (k,with_cents) r = + if r < 1 || r >= 2 + then error (show ("rat_label",r)) + else concat [pc_pp (ratio_to_pc k r) + ,if with_cents + then '=' : cents_pp r + else "" + ,"\\n",T.ratio_pp r] + +-- > rat_id (5/4) == "R_5_4" +rat_id :: Rational-> String +rat_id r = "R_" ++ show (numerator r) ++ "_" ++ show (denominator r) + +rat_edge_label :: (Rational, Rational) -> String +rat_edge_label (p,q) = concat [" (",T.ratio_pp (rat_div p q),")"] + +-- | Zip start-middle-end. +-- +-- > zip_sme (0,1,2) "abcd" == [(0,'a'),(1,'b'),(1,'c'),(2,'d')] +zip_sme :: (t,t,t) -> [u] -> [(t,u)] +zip_sme (s,m,e) xs = + case xs of + x0:x1:xs' -> (s,x0) : (m,x1) : T.at_last (\x -> (m,x)) (\x -> (e,x)) xs' + _ -> error "zip_sme: not SME list" + +type Euler_Plane t = ([[t]],[(t,t)]) + +euler_plane_to_dot :: (t -> String,t -> String,(t,t) -> String) -> Euler_Plane t -> [String] +euler_plane_to_dot (n_id,n_pp,e_pp) (h,v) = + let mk_lab_term x =concat [" [label=\"",x,"\"];"] + node_to_dot x = concat [n_id x,mk_lab_term (n_pp x)] + subgraph_edges x = intercalate " -- " (map n_id x) ++ ";" + edge_to_dot (lhs,rhs) = concat [n_id lhs," -- ",n_id rhs,mk_lab_term (e_pp (lhs,rhs))] + subgraphs_to_dot (ty,x) = concat ["{rank=",ty,"; ",unwords (map n_id x),"}"] + in ["graph g {" + ,"graph [layout=\"dot\",rankdir=\"TB\",nodesep=0.5];" + ,"edge [fontsize=\"8\",fontname=\"century schoolbook\"];" + ,"node [shape=\"plaintext\",fontsize=\"10\",fontname=\"century schoolbook\"];"] ++ + map node_to_dot (concat h) ++ + map subgraph_edges h ++ + map edge_to_dot v ++ + map subgraphs_to_dot (zip_sme ("min","same","max") h) ++ + ["}"] + +euler_plane_to_dot_rat :: (Int, Bool) -> Euler_Plane Rational -> [String] +euler_plane_to_dot_rat opt = euler_plane_to_dot (rat_id,rat_label opt,rat_edge_label) + +{- + +let j5 = + let {l1 = tun_seq 3 (3%2) (5%3) + ;l2 = tun_seq 5 (3%2) (16%9) + ;l3 = tun_seq 4 (3%2) (64%45) + ;(c1,c2) = euler_align_rat (5%8,5%4) (l1,l2,l3)} + in ([l1,l2,l3],c1 ++ c2) + +let j5' = + let {f = T.fold_ratio_to_octave_err + ;l1 = tun_seq 4 (3/2) (f (1 * 2/3 * 5/4)) + ;l2 = tun_seq 5 (3/2) (f (1 * 2/3 * 2/3)) + ;l3 = tun_seq 3 (3/2) (f (1 * 2/3 * 4/5)) + ;(c1,c2) = euler_align_rat (5/4,5/4) (l1,l2,l3)} + in ([l1,l2,l3],c1 ++ c2) + +let j7 = + let {l1 = tun_seq 4 (3%2) (5%4) + ;l2 = tun_seq 5 (3%2) (4%3) + ;l3 = tun_seq 3 (3%2) (14%9) + ;(c1,c2) = euler_align_rat (5%4,4%7) (l1,l2,l3)} + in ([l1,l2,l3],c1 ++ c2) + +let dir = "/home/rohan/sw/hmt/data/dot/" +let f = unlines . euler_plane_to_dot_rat (0,False) +writeFile (dir ++ "euler-j5-a.dot") (f j5) +writeFile (dir ++ "euler-j5-b.dot") (f j5') +writeFile (dir ++ "euler-j7.dot") (f j7) + +-} diff --git a/Music/Theory/Tuning/Gann.hs b/Music/Theory/Tuning/Gann.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Gann.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | 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 diff --git a/Music/Theory/Tuning/Gann_1993.hs b/Music/Theory/Tuning/Gann_1993.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Gann_1993.hs @@ -0,0 +1,139 @@ +-- | Kyle Gann. "La Monte Young's The Well-Tuned Piano". +-- /Perspectives of New Music/, 31(1):134--162, Winter 1993. +module Music.Theory.Tuning.Gann_1993 where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuning.Euler as T {- hmt -} + +{- | Ratios for 'lmy_wtp'. lmy = La Monte Young. wtp = Well-Tuned Piano. + +> let c = [0,177,204,240,471,444,675,702,738,969,942,1173] +> in map (round . T.ratio_to_cents) lmy_wtp_r == c + +-} +lmy_wtp_r :: [Rational] +lmy_wtp_r = + [1,567/512 + ,9/8,147/128 + ,21/16 + ,1323/1024,189/128 + ,3/2,49/32 + ,7/4,441/256 + ,63/32] + +-- | The pitch-class of the key associated with each ratio of the tuning. +-- +-- > mapMaybe lmy_wtp_ratio_to_pc [1,1323/1024,7/4] == [3,8,0] +lmy_wtp_ratio_to_pc :: Rational -> Maybe T.PitchClass +lmy_wtp_ratio_to_pc r = fmap (T.mod12 . (+ 3)) (elemIndex r lmy_wtp_r) + +lmy_wtp_ratio_to_pc_err :: Rational -> T.PitchClass +lmy_wtp_ratio_to_pc_err = fromMaybe (error "lmy_wtp_ratio_to_pc") . lmy_wtp_ratio_to_pc + +-- | The list of all non-unison ascending intervals possible in 'lmy_wtp_r'. +-- +-- > length lmy_wtp_univ == 66 +lmy_wtp_univ :: [(Rational,(T.PitchClass,T.PitchClass))] +lmy_wtp_univ = + let f (p,q) = if p < q + then Just (T.ratio_interval_class (p/q) + ,(lmy_wtp_ratio_to_pc_err p + ,lmy_wtp_ratio_to_pc_err q)) + else Nothing + in mapMaybe f (T.all_pairs lmy_wtp_r lmy_wtp_r) + +{- | Collated and sorted 'lmy_wtp_univ'. + +> let r_cents_pp = show . round . T.ratio_to_cents + +> import qualified Music.Theory.Math as T {- hmt -} + +> let f (r,i) = concat [T.ratio_pp r," = " +> ,r_cents_pp r," = #" +> ,show (length i)," = " +> ,unwords (map show i)] + +> putStrLn $ unlines $ map f lmy_wtp_uniq + +3:2 = 702 = #9 = (3,10) (4,9) (5,10) (6,11) (6,1) (7,0) (7,2) (8,1) (9,2) +7:4 = 969 = #7 = (3,0) (5,2) (6,7) (7,10) (8,9) (11,0) (1,2) +7:6 = 267 = #6 = (4,8) (5,7) (6,2) (7,11) (9,1) (10,0) +9:7 = 435 = #4 = (4,1) (5,0) (6,9) (11,2) +9:8 = 204 = #6 = (3,5) (4,2) (6,8) (7,9) (11,1) (0,2) +21:16 = 471 = #6 = (3,7) (5,9) (6,0) (7,1) (8,2) (10,2) +27:14 = 1137 = #2 = (4,6) (9,11) +27:16 = 906 = #3 = (4,7) (8,11) (9,0) +49:32 = 738 = #3 = (3,11) (5,1) (6,10) +49:36 = 534 = #1 = (5,11) +63:32 = 1173 = #5 = (3,2) (4,5) (8,7) (9,10) (1,0) +49:48 = 36 = #2 = (5,6) (10,11) +81:56 = 639 = #1 = (4,11) +81:64 = 408 = #1 = (4,0) +147:128 = 240 = #3 = (3,6) (5,8) (10,1) +189:128 = 675 = #3 = (3,9) (4,10) (8,0) +441:256 = 942 = #2 = (3,1) (8,10) +567:512 = 177 = #1 = (3,4) +1323:1024 = 444 = #1 = (3,8) + +-} +lmy_wtp_uniq :: [(Rational,[(T.PitchClass,T.PitchClass)])] +lmy_wtp_uniq = sortOn (T.ratio_nd_sum . fst) $ T.collate_on fst snd $ lmy_wtp_univ + +{- | Gann, 1993, p.137. + +> cents_i lmy_wtp == [0,177,204,240,471,444,675,702,738,969,942,1173] + +> import Data.List {- base -} +> import Music.Theory.Tuning.Scala {- hmt -} +> scl <- scl_load "young-lm_piano" +> cents_i (scale_to_tuning 0.01 scl) == cents_i lmy_wtp + +> let f = d12_midi_tuning_f (lmy_wtp,-74.7,-3) +> import qualified Music.Theory.Pitch as T +> T.octpc_to_midi (-1,11) == 11 +> map (round . T.midi_detune_to_cps . f) [62,63,69] == [293,298,440] +> map (fmap round . T.midi_detune_normalise . f) [0 .. 127] + +-} +lmy_wtp :: T.Tuning +lmy_wtp = T.Tuning (Left lmy_wtp_r) 2 + +-- | Ratios for 'lmy_wtp_1964. +lmy_wtp_1964_r :: [Rational] +lmy_wtp_1964_r = + let n = [1,279,9,147,21,93,189,3,49,7,31,63] + d = [1,256,8,128,16,64,128,2,32,4,16,32] + in zipWith (/) n d + +{- | La Monte Young's initial 1964 tuning for \"The Well-Tuned Piano\" (Gann, 1993, p.141). + +> cents_i lmy_wtp_1964 == [0,149,204,240,471,647,675,702,738,969,1145,1173] + +> import Music.Theory.Tuning.Scala +> let nm = ("young-lm_piano_1964","LaMonte Young's Well-Tuned Piano (1964)") +> let scl = tuning_to_scale nm lmy_wtp_1964 +> putStr $ unlines $ scale_pp scl + +-} +lmy_wtp_1964 :: T.Tuning +lmy_wtp_1964 = T.Tuning (Left lmy_wtp_1964_r) 2 + +{- | Euler diagram for 'lmy_wtp'. + +let dir = "/home/rohan/sw/hmt/data/dot/" +let f = unlines . T.euler_plane_to_dot_rat (3,True) +writeFile (dir ++ "euler-wtp.dot") (f lmy_wtp_euler) + +-} +lmy_wtp_euler :: T.Euler_Plane Rational +lmy_wtp_euler = + let {l1 = T.tun_seq 4 (3/2) (49/32) + ;l2 = T.tun_seq 5 (3/2) (7/4) + ;l3 = T.tun_seq 3 (3/2) (1/1) + ;(c1,c2) = T.euler_align_rat (7/4,7/4) (l1,l2,l3)} + in ([l1,l2,l3],c1 ++ c2) diff --git a/Music/Theory/Tuning/Load.hs b/Music/Theory/Tuning/Load.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Load.hs @@ -0,0 +1,78 @@ +-- | Functions to load a tuning definition and transform it into a sparse tuning function. +module Music.Theory.Tuning.Load where + +import System.Random {- random -} + +import qualified Music.Theory.Array.CSV as T +import qualified Music.Theory.Pitch as T +import qualified Music.Theory.Tuning as T +import qualified Music.Theory.Tuning.Scala as T + +-- | Load possibly sparse and possibly one-to-many +-- (midi-note-number,cps-frequency) table from CSV file. +-- +-- > load_cps_tbl "/home/rohan/dr.csv" +load_cps_tbl :: FilePath -> IO [(Int,Double)] +load_cps_tbl nm = do + tbl <- T.csv_table_read_def id nm + let f e = case e of + [p,q] -> (read p,read q) + _ -> error "load_cps_tbl" + return (map f tbl) + +-- | Load scala scl file as 'T.Tuning'. +load_tuning_scl :: String -> IO T.Tuning +load_tuning_scl = fmap (T.scale_to_tuning 0.01) . T.scl_load + +-- | Load scala file and apply 'T.cps_midi_tuning_f'. +load_tuning_cps :: (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F +load_tuning_cps (nm,f0,k) = + let f tn = T.cps_midi_tuning_f (tn,f0,k,128-k) + in fmap f (load_tuning_scl nm) + +-- | Load scala file and apply 'T.d12_midi_tuning_f'. +load_tuning_d12 :: (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F +load_tuning_d12 (nm,dt,k) = + let f tn = T.lift_tuning_f (T.d12_midi_tuning_f (tn,dt,k)) + in fmap f (load_tuning_scl nm) + +-- | Lookup first matching element in table. +load_tuning_tbl :: (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F +load_tuning_tbl (nm,dt,k) = + let from_cps = T.cps_to_midi_detune . flip T.cps_shift_cents dt + f tbl mnn = fmap from_cps (lookup (mnn + k) tbl) + in fmap f (load_cps_tbl nm) + +type Choose_f st t = [t] -> st-> (t,st) + +-- | Randomly choose from elements in table, equal weighting. +default_choose_f :: RandomGen g => Choose_f g t +default_choose_f l g = + let (i,g') = randomR (0,length l - 1) g + in (l !! i,g') + +-- | Load tuning table with stateful selection function for one-to-many entries. +load_tuning_tbl_st :: Choose_f st (Int,Double) -> (String,Double,Int) -> IO (T.Sparse_Midi_Tuning_ST_F st) +load_tuning_tbl_st choose_f (nm,dt,k) = + let from_cps = T.cps_to_midi_detune . flip T.cps_shift_cents dt + f tbl g mnn = case filter ((== (mnn + k)) . fst) tbl of + [] -> (g,Nothing) + l -> let ((_,e),g') = choose_f l g + in (g',Just (from_cps e)) + in fmap f (load_cps_tbl nm) + +load_tuning_ty :: String -> (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F +load_tuning_ty ty opt = + case ty of + "cps" -> load_tuning_cps opt + "d12" -> load_tuning_d12 opt + "tbl" -> load_tuning_tbl opt + _ -> error "cps|d12|tbl" + +load_tuning_st_ty :: String -> (String,Double,Int) -> IO (T.Sparse_Midi_Tuning_ST_F StdGen) +load_tuning_st_ty ty opt = + case ty of + "cps" -> fmap T.lift_sparse_tuning_f (load_tuning_cps opt) + "d12" -> fmap T.lift_sparse_tuning_f (load_tuning_d12 opt) + "tbl" -> load_tuning_tbl_st default_choose_f opt + _ -> error "cps|d12|tbl" diff --git a/Music/Theory/Tuning/Meyer_1929.hs b/Music/Theory/Tuning/Meyer_1929.hs --- a/Music/Theory/Tuning/Meyer_1929.hs +++ b/Music/Theory/Tuning/Meyer_1929.hs @@ -3,8 +3,9 @@ -- University of Missouri, 1929. p.22 module Music.Theory.Tuning.Meyer_1929 where -import Data.List -import Data.Ratio +import Data.List {- base -} +import Data.Ratio {- base -} + import qualified Music.Theory.Tuning as T -- | Odd numbers to /n/. @@ -17,17 +18,17 @@ -- -- > 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) +row = sort . map T.fold_ratio_to_octave_err . 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 +column = map (T.fold_ratio_to_octave_err . 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) +in_oct_mul i j = T.fold_ratio_to_octave_err (i * j) -- | Given /row/ and /column/ generate matrix value at /(i,j)/. -- diff --git a/Music/Theory/Tuning/Microtonal_Synthesis.hs b/Music/Theory/Tuning/Microtonal_Synthesis.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Microtonal_Synthesis.hs +++ /dev/null @@ -1,205 +0,0 @@ --- | -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 diff --git a/Music/Theory/Tuning/Polansky_1978.hs b/Music/Theory/Tuning/Polansky_1978.hs --- a/Music/Theory/Tuning/Polansky_1978.hs +++ b/Music/Theory/Tuning/Polansky_1978.hs @@ -1,30 +1,46 @@ --- | Larry Polansky. \"Psaltery (for Lou Harrison)\". Frog Peak Music, --- 1978. +-- | Larry Polansky. \"Psaltery (for Lou Harrison)\". +-- Frog Peak Music, 1978. module Music.Theory.Tuning.Polansky_1978 where -import Data.List +import Data.List {- base -} + 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] +{- | Three interlocking harmonic series on 1:5:3, by Larry Polansky in \"Psaltery\". --- | '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)) +> import qualified Music.Theory.Tuning.Scala as T +> scl <- T.scl_load "polansky_ps" +> T.pitch_representations (T.scale_pitches scl) == (0,50) +> 1 : Data.Either.rights (T.scale_pitches scl) == psaltery_r --- Local Variables: --- truncate-lines:t --- End: +-} +psaltery_r :: [Rational] +psaltery_r = + let sq_at n = map (* n) [1..17] + in concat [sq_at 1,sq_at (5/4),sq_at (3/2)] + +{- | 'T.fold_ratio_to_octave'' of 'psaltery'. + +> length psaltery_r == 51 && length psaltery_o_r == 21 + +> psaltery_o_r == [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_r :: [Rational] +psaltery_o_r = nub (sort (map T.fold_ratio_to_octave_err psaltery_r)) + +{- | 'Tuning' derived from 'psaltery_o' with 'octave_ratio' of @2@. + +> cents_i psaltery_o == [0,27,53,105,155,204,275,342,386,471,491,551,590 + ,702,773,807,841,906,938,969,1088] + +> let r = [0,1200,1902,2400,2786,3102,3369,3600,3804,3986,4151,4302,4441,4569,4688,4800,4905 + ,386,1586,2288,2786,3173,3488,3755,3986,4190,4373,4538,4688,4827,4955,5075,5186,5291 + ,702,1902,2604,3102,3488,3804,4071,4302,4506,4688,4853,5004,5142,5271,5390,5502] +> in cents_i (T.scale_tuning 0.01 scl) == r + +-} +psaltery_o :: T.Tuning +psaltery_o = T.Tuning (Left psaltery_o_r) 2 diff --git a/Music/Theory/Tuning/Polansky_1984.hs b/Music/Theory/Tuning/Polansky_1984.hs --- a/Music/Theory/Tuning/Polansky_1984.hs +++ b/Music/Theory/Tuning/Polansky_1984.hs @@ -2,9 +2,11 @@ -- 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 +import Data.List {- base -} +import qualified Music.Theory.List as T +import qualified Music.Theory.Tuning as T + k_manisrenga :: Fractional n => [n] k_manisrenga = [219.5,266.5,227,233.5,258.5] @@ -100,12 +102,6 @@ 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 == @@ -128,7 +124,7 @@ -- > ,"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)) +i_category_table = map (intercalate " " . map (T.pad_right ' ' 3 . i_category)) -- | Rational tuning derived from 'gm_averages', p.11. -- @@ -148,5 +144,5 @@ -- -- > 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 +polansky_1984_c :: [T.Cents] +polansky_1984_c = map T.ratio_to_cents polansky_1984_r diff --git a/Music/Theory/Tuning/Riley.hs b/Music/Theory/Tuning/Riley.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Riley.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | 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 diff --git a/Music/Theory/Tuning/Rosenboom_1979.hs b/Music/Theory/Tuning/Rosenboom_1979.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Rosenboom_1979.hs @@ -0,0 +1,190 @@ +-- | David Rosenboom, "In the Beginning: Etude I (Trombones)", 1979 +-- +-- +-- kw: subharmonics, difference tones +module Music.Theory.Tuning.Rosenboom_1979 where + +import Data.List {- base -} +import Data.Ratio {- base -} + +import qualified Music.Theory.List as T +import qualified Music.Theory.Pitch as T +import qualified Music.Theory.Pitch.Name as T +import qualified Music.Theory.Tuning.ET as T +import qualified Music.Theory.Tuning.Scala as Scala +import qualified Music.Theory.Tuple as T + +t2_to_ratio :: (Integer,Integer) -> Rational +t2_to_ratio (n,d) = n % d + +-- | Tuning, ratios for each octave. +-- +-- > length (concat dr_tuning_oct) == 19 +-- > import qualified Music.Theory.Tuning as T +-- > map (map (T.ratio_to_cents . t2_to_ratio)) dr_tuning_oct +dr_tuning_oct :: Num n => [[(n,n)]] +dr_tuning_oct = + [[(1,1),(4,3),(16,11),(8,5),(16,9)] + ,[(1,1),(8,7),(4,3),(3,2),(8,5),(16,9)] + ,[(1,1),(9,8),(5,4),(4,3),(11,8),(3,2),(8,5),(7,4)]] + +-- | Tuning, actual ratios. +dr_tuning :: [Rational] +dr_tuning = concat (zipWith (\o -> map ((* o) . t2_to_ratio)) [1,2,4] dr_tuning_oct) + +-- | Actual scale, in CPS. +-- +-- > let r = [52,69,76,83,92,104,119,138,156,166,185,208,234,260,277,286,311,332,363] +-- > in map round dr_scale == r +dr_scale :: [Double] +dr_scale = + let f0 = T.octpc_to_cps (1::Int,8) + f = (* f0) . fromRational + in map f dr_tuning + +-- > putStrLn (unlines (map (unwords . T.hs_r_pitch_pp 1) dr_scale_tbl_12et)) +-- > map (\(f,p,_,_,_) -> (T.pitch_to_midi p,f)) dr_scale_tbl_12et +dr_scale_tbl_12et :: [T.HS_R T.Pitch] +dr_scale_tbl_12et = map T.nearest_12et_tone dr_scale + +{- + +51.9 A♭1 51.9 0.0 0.0 +69.2 C♯2 69.3 -0.1 -2.0 +75.5 D2 73.4 2.1 48.7 +83.1 E2 82.4 0.7 13.7 +92.3 F♯2 92.5 -0.2 -3.9 +103.8 A♭2 103.8 0.0 0.0 +118.7 B♭2 116.5 2.1 31.2 +138.4 C♯3 138.6 -0.2 -2.0 +155.7 E♭3 155.6 0.2 2.0 +166.1 E3 164.8 1.3 13.7 +184.6 F♯3 185.0 -0.4 -3.9 +207.7 A♭3 207.7 0.0 0.0 +233.6 B♭3 233.1 0.5 3.9 +259.6 C4 261.6 -2.1 -13.7 +276.9 C♯4 277.2 -0.3 -2.0 +285.5 D4 293.7 -8.1 -48.7 +311.5 E♭4 311.1 0.4 2.0 +332.2 E4 329.6 2.6 13.7 +363.4 F♯4 370.0 -6.6 -31.2 + +-} + +-- > Scala.scale_verify dr_scale_scala +-- > putStrLn $ unlines $ Scala.scale_pp dr_scale_scala +dr_scale_scala :: Scala.Scale Integer +dr_scale_scala = + let f (r,(_,p,_,_,_)) = (T.pitch_to_midi p :: Int,r) + sq = map f (zip dr_tuning dr_scale_tbl_12et) + g z k = case lookup k sq of + Nothing -> (z,(k,z)) + Just r -> (r,(k,r)) + r_seq = snd (mapAccumL g 1 [33 .. 32 + 12 * 3 - 1]) ++ [(68,8)] + in ("dr_itb_etude_1","...",3 * 12,map (Right . snd) r_seq) + +-- > putStrLn (unlines (map (unwords . T.hs_r_pitch_pp 1) dr_scale_tbl_24et)) +dr_scale_tbl_24et :: [T.HS_R T.Pitch] +dr_scale_tbl_24et = map T.nearest_24et_tone dr_scale + +{- + +51.9 A♭1 51.9 0.0 0.0 +69.2 C♯2 69.3 -0.1 -2.0 +75.5 D𝄲2 75.6 -0.1 -1.3 +83.1 E2 82.4 0.7 13.7 +92.3 F♯2 92.5 -0.2 -3.9 +103.8 A♭2 103.8 0.0 0.0 +118.7 B𝄳2 120.0 -1.3 -18.8 +138.4 C♯3 138.6 -0.2 -2.0 +155.7 E♭3 155.6 0.2 2.0 +166.1 E3 164.8 1.3 13.7 +184.6 F♯3 185.0 -0.4 -3.9 +207.7 A♭3 207.7 0.0 0.0 +233.6 B♭3 233.1 0.5 3.9 +259.6 C4 261.6 -2.1 -13.7 +276.9 C♯4 277.2 -0.3 -2.0 +285.5 D𝄳4 285.3 0.2 1.3 +311.5 E♭4 311.1 0.4 2.0 +332.2 E4 329.6 2.6 13.7 +363.4 F𝄲4 359.5 3.9 18.8 + +-} + +dr_chords :: [[T.Pitch]] +dr_chords = + [[T.aes1,T.bes2,T.des3,T.ees4] -- S1 + ,[T.aes1,T.aes2,T.fes3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] -- S2 + ,[T.aes1,T.ges2,T.aes3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] -- S3 + ,[T.aes1,T.ges2,T.aes3,T.ees4] + ,[T.aes1,T.ges2,T.aes3,T.ees4] -- S4 + ,[T.aes1,T.aes2,T.fes3,T.ees4] + ,[T.aes1,T.fes2,T.des4,T.ees4] -- S5 + ,[T.ges2,T.aes2,T.aes3,T.d4] + ,[T.aes1,T.d2,T.aes3,T.ees4] + ,[T.aes2,T.fes3,T.d4] -- S6 + ,[T.aes1,T.fes2,T.des4,T.ees4] + ,[T.aes1,T.fes2,T.des4,T.ees4] -- S7 + ,[T.aes1,T.ges2,T.aes3,T.ees4] + ,[T.aes1,T.ges2,T.aes3,T.ees4] -- S8 + ,[T.aes1,T.d2,T.aes3,T.ees4] + ] + +-- > sum (map snd (concat dr_ratio_seq)) == 20 * 11 +-- > map (sum . map snd) dr_ratio_seq == replicate 20 11 +dr_ratio_seq :: Num n => [[(n,n)]] +dr_ratio_seq = + [[(11,3),(2,2),(6,6)] + ,[(7,2),(7,7),(6,2)] + ,[(6,9),(2,2)] + ,[(2,9),(11,2)] + ,[(10,5),(10,3),(10,3)] + ,[(10,10),(5,1)] + ,[(5,7),(11,4)] + ,[(11,3),(8,8)] + ,[(8,8),(10,3)] -- p2 + ,[(10,7),(10,4)] + ,[(10,4),(3,3),(4,4)] + ,[(4,3),(9,7),(5,1)] + ,[(7,7),(7,4)] + ,[(9,9),(9,2)] + ,[(9,7),(7,4)] + ,[(7,3),(9,4),(7,4)] + ,[(5,3),(4,4),(6,1),(4,3)] + ,[(4,4),(7,7)] + ,[(7,2),(5,8),(8,1)] + ,[(8,1),(1,10)] + ] + +-- > import Data.Function +-- > import Data.List +-- > reverse (sortBy (compare `on` snd) dr_ratio_seq_hist) +dr_ratio_seq_hist :: (Ord n,Num n) => [((n,n),Int)] +dr_ratio_seq_hist = T.histogram (concat dr_ratio_seq) + +dr_nt :: Integral i => [([i],[i])] +dr_nt = + [([1,7,8,17],[12,13,15,17]) + ,([1,6,10,17],[6,10,9])] + +-- > map (T.bimap1 (map T.pitch_pp) . dr_nt_pitch) dr_nt +dr_nt_pitch :: ([Int], [Int]) -> ([T.Pitch], [T.Pitch]) +dr_nt_pitch = + let f k = T.p5_snd (dr_scale_tbl_24et !! (k - 1)) + in T.bimap1 (map f) + +{- + +-- from harmonic series +hs :: Num n => [(n,n)] +hs = [(1,1),(9,8),(5,4),(11,8),(3,2),(7,4)] + +-- from subharmonic series +shs :: Num n => [(n,n)] +shs = [(8,7),(16,11),(8,5),(16,9)] + +-} diff --git a/Music/Theory/Tuning/Scala.hs b/Music/Theory/Tuning/Scala.hs --- a/Music/Theory/Tuning/Scala.hs +++ b/Music/Theory/Tuning/Scala.hs @@ -1,38 +1,112 @@ -- | Parser for the Scala scale file format. See -- for details. --- This module succesfully parses all 4496 scales in v.81 of the scale +-- This module succesfully parses all 4671 scales in v.85 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 Control.Monad {- base -} +import Data.Either {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} import System.Directory {- directory -} +import System.Environment {- base -} import System.FilePath {- filepath -} +import qualified Music.Theory.Directory as T {- hmt -} +import qualified Music.Theory.Either as T {- hmt -} +import qualified Music.Theory.Function as T {- hmt -} +import qualified Music.Theory.IO as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Math as T {- hmt -} +import qualified Music.Theory.Read as T {- hmt -} +import qualified Music.Theory.String as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} + +-- * Pitch + -- | 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]) +-- | An enumeration type for @.scl@ pitch classification. +data Pitch_Type = Pitch_Cents | Pitch_Ratio deriving (Eq,Show) --- | Text description of scale. +-- | A nearness value for deriving approximate rationals. +type Epsilon = Double + +-- | Derive 'Pitch_Type' from 'Pitch'. +pitch_type :: Pitch i -> Pitch_Type +pitch_type = either (const Pitch_Cents) (const Pitch_Ratio) + +-- | Pitch as 'T.Cents', conversion by 'T.ratio_to_cents' if necessary. +pitch_cents :: Integral i => Pitch i -> T.Cents +pitch_cents p = + case p of + Left c -> c + Right r -> T.ratio_to_cents r + +-- | 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 + +-- | A pair giving the number of 'Cents' and number of 'Ratio' pitches. +pitch_representations :: Integral t => [Pitch i] -> (t,t) +pitch_representations = + let f (l,r) p = case p of + Left _ -> (l + 1,r) + Right _ -> (l,r + 1) + in foldl f (0,0) + +-- | If scale is uniform, give type. +uniform_pitch_type :: [Pitch i] -> Maybe Pitch_Type +uniform_pitch_type p = + case pitch_representations p :: (Int,Int) of + (0,_) -> Just Pitch_Ratio + (_,0) -> Just Pitch_Cents + _ -> Nothing + +-- | The predominant type of the pitches for 'Scale'. +pitch_type_predominant :: [Pitch i] -> Pitch_Type +pitch_type_predominant p = + let (c,r) = pitch_representations p :: (Int,Int) + in if c >= r then Pitch_Cents else Pitch_Ratio + +-- * Scale + +-- | A scale has a name, a description, a degree, and a list of 'Pitch'es. +type Scale i = (String,String,Int,[Pitch i]) + +-- | The name of a scale. +scale_name :: Scale i -> String +scale_name (nm,_,_,_) = nm + +-- | Text description of a scale. scale_description :: Scale i -> String -scale_description (d,_,_) = d +scale_description (_,d,_,_) = d -- | The degree of the scale (number of 'Pitch'es). -scale_degree :: Scale i -> i -scale_degree (_,n,_) = n +scale_degree :: Scale i -> Int +scale_degree (_,_,n,_) = n -- | The 'Pitch'es at 'Scale'. scale_pitches :: Scale i -> [Pitch i] -scale_pitches (_,_,p) = p +scale_pitches (_,_,_,p) = p +-- | Ensure degree and number of pitches align. +scale_verify :: Scale i -> Bool +scale_verify (_,_,n,p) = n == length p + +-- | Raise error if scale doesn't verify, else 'id'. +scale_verify_err :: Scale i -> Scale i +scale_verify_err scl = if scale_verify scl then scl else error "invalid scale" + -- | The last 'Pitch' element of the scale (ie. the /ocatve/). scale_octave :: Scale i -> Maybe (Pitch i) -scale_octave (_,_,s) = +scale_octave (_,_,_,s) = case s of [] -> Nothing _ -> Just (last s) @@ -42,155 +116,269 @@ 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 +-- | Are all pitches of the same type. +is_scale_uniform :: Scale i -> Bool +is_scale_uniform = isJust . uniform_pitch_type . scale_pitches -- | 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_uniform epsilon (nm,d,n,p) = + case pitch_type_predominant p of + Pitch_Cents -> (nm,d,n,map (Left . pitch_cents) p) + Pitch_Ratio -> (nm,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 :: Integral i => Scale i -> [T.Cents] scale_cents s = 0 : map pitch_cents (scale_pitches s) +-- | 'map' 'round' of 'scale_cents'. +scale_cents_i :: Integral i => Scale i -> [i] +scale_cents_i = map round . scale_cents + -- | 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 = +-- | Require that 'Scale' be uniformlay of 'Ratio's. +scale_ratios_req :: Integral i => Scale i -> [Ratio i] +scale_ratios_req = + let err = error "scale_ratios_req" + in (1 :) . map (fromMaybe err . T.fromRight) . scale_pitches + +-- | Translate 'Scale' to 'T.Tuning'. If 'Scale' is uniformly +-- rational, 'T.Tuning' is rational, else 'T.Tuning' is in 'T.Cents'. +-- 'Epsilon' is used to recover the 'Rational' octave if required. +scale_to_tuning :: Epsilon -> Scale Integer -> T.Tuning +scale_to_tuning epsilon (_,_,_,p) = + case partitionEithers p of + ([],r) -> let (r',o) = T.separate_last r + in T.Tuning (Left (1 : r')) o + _ -> let (c,o) = T.separate_last p + c' = 0 : map pitch_cents c + o' = either (T.reconstructed_ratio epsilon) id o + in T.Tuning (Right c') o' + +-- | Convert 'T.Tuning' to 'Scale'. +-- +-- > tuning_to_scale ("et12","12 tone equal temperament") (T.equal_temperament 12) +tuning_to_scale :: (String,String) -> T.Tuning -> Scale Integer +tuning_to_scale (nm,dsc) (T.Tuning p o) = + let n = either length length p + p' = either (map Right . tail) (map Left . tail) p ++ [Right o] + in (nm,dsc,n,p') + +{- | Are scales equal ('==') at degree and tuning data. + +> db <- scl_load_db +> let r = [2187/2048,9/8,32/27,81/64,4/3,729/512,3/2,6561/4096,27/16,16/9,243/128,2/1] +> let Just py = find (scale_eq ("","",12,map Right r)) db +> scale_name py == "pyth_12" + +> let c = map T.ratio_to_cents r +> let Just py' = find (scale_eqv ("","",12,map Left c)) db +> scale_name py' == "pyth_12" +-} +scale_eq :: Eq n => Scale n -> Scale n -> Bool +scale_eq (_,_,d0,p0) (_,_,d1,p1) = d0 == d1 && p0 == p1 + +-- | Are scales equal ('==') at degree and tuning data after 'pitch_cents'. +scale_eqv :: Integral n => Scale n -> Scale n -> Bool +scale_eqv (_,_,d0,p0) (_,_,d1,p1) = + let f = map pitch_cents + in d0 == d1 && f p0 == f p1 + +-- * Parser + +-- | Comment lines begin with @!@. +is_comment :: String -> Bool +is_comment 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 " 1 ! comment" == " 1 " remove_eol_comments :: String -> String remove_eol_comments = takeWhile (/= '!') --- | Remove comments and null lines. +-- | Remove comments and null lines and trailing comments. -- --- > filter_comments ["!a","b","","c"] == ["b","c"] +-- > filter_comments ["!a","b","","c","d!e"] == ["b","c","d"] 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 +filter_comments = + map remove_eol_comments . + filter (not . T.predicate_any [is_comment,null]) --- | Pitches are either cents (with decimal point) or ratios (with @/@). +-- | Pitches are either cents (with decimal point, possibly trailing) 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 = +-- > map parse_pitch ["700.0","350.","3/2","2"] == [Left 700,Left 350,Right (3/2),Right 2] +parse_pitch :: (Read i,Integral i) => String -> Pitch i +parse_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) + then Left (T.read_fractional_allow_trailing_point_err p) + else Right (T.read_ratio_with_div_err p) -- | Pitch lines may contain commentary. -pitch_ln :: (Read i, Integral i) => String -> Pitch i -pitch_ln x = +parse_pitch_ln :: (Read i, Integral i) => String -> Pitch i +parse_pitch_ln x = case words x of - p:_ -> pitch p - _ -> error (show ("pitch",words x)) + p:_ -> parse_pitch p + _ -> error (show ("parse_pitch_ln",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) +parse_scl :: (Read i, Integral i) => String -> String -> Scale i +parse_scl nm s = + case filter_comments (lines (T.filter_cr s)) of + t:n:p -> let scl = (nm,T.delete_trailing_whitespace t,T.read_err n,map parse_pitch_ln p) + in scale_verify_err scl _ -> error "parse" --- | Load @.scl@ file. +-- * IO + +-- | Read the environment variable @SCALA_SCL_DIR@, which is a +-- sequence of directories used to locate scala files on. -- --- > 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) +-- > setEnv "SCALA_DIST_DIR" "/home/rohan/data/scala/85/scl" +scl_get_dir :: IO [String] +scl_get_dir = fmap splitSearchPath (getEnv "SCALA_SCL_DIR") --- | 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))) +-- | Lookup the @SCALA_SCL_DIR@ environment variable, which must exist, and derive the filepath. +-- It is an error if the name has a file extension. +-- +-- > mapM scl_derive_filename ["young-lm_piano","et12"] +scl_derive_filename :: FilePath -> IO FilePath +scl_derive_filename nm = do + dir <- scl_get_dir + when (null dir) (error "scl_derive_filename: SCALA_SCL_DIR: nil") + when (hasExtension nm) (error "scl_derive_filename: name has extension") + T.path_scan_err dir (nm <.> "scl") --- | Load all @.scl@ files at /dir/. +-- | If the name is an absolute file path and has a @.scl@ extension, +-- then return it, else run 'scl_derive_filename'. -- --- > 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 +-- > scl_resolve_name "young-lm_piano" +-- > scl_resolve_name "/home/rohan/data/scala/85/scl/young-lm_piano.scl" +-- > scl_resolve_name "/home/rohan/data/scala/85/scl/unknown-tuning.scl" +scl_resolve_name :: String -> IO FilePath +scl_resolve_name nm = + let ex_f x = if x then return nm else error "scl_resolve_name: file does not exist" + in if isAbsolute nm && takeExtension nm == ".scl" + then doesFileExist nm >>= ex_f + else scl_derive_filename nm + +-- | Load @.scl@ file, runs 'resolve_scl'. -- --- > 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 +-- > s <- scl_load "xenakis_chrom" +-- > pitch_representations (scale_pitches s) == (6,1) +-- > scale_ratios 1e-3 s == [1,21/20,29/23,179/134,280/187,11/7,100/53,2] +scl_load :: (Read i, Integral i) => String -> IO (Scale i) +scl_load nm = do + fn <- scl_resolve_name nm + s <- T.read_file_iso_8859_1 fn + return (parse_scl (takeBaseName nm) s) + +-- | 'scale_to_tuning' of 'scl_load'. +scl_load_tuning :: Epsilon -> String -> IO T.Tuning +scl_load_tuning epsilon = fmap (scale_to_tuning epsilon) . scl_load + +{- | Load all @.scl@ files at /dir/. + +> dir <- scl_get_dir +> dir == ["/home/rohan/data/scala/85/scl","/home/rohan/sw/hmt/data/scl"] +> let [scl_85_dir,ext_dir] = dir +> db <- scl_load_dir scl_85_dir +> length db == 4671 +> length (filter ((== 0) . scale_degree) db) == 0 +> length (filter ((/= 1) . head . scale_ratios 1e-3) db) == 0 +> length (filter ((/= 0) . head . scale_cents) db) == 0 +> length (filter (== Just (Right 2)) (map scale_octave db)) == 4003 +> length (filter is_scale_uniform db) == 2816 + +> let na = filter (not . T.is_ascending . scale_cents) db +> length na == 121 +> mapM_ (putStrLn . unlines . scale_stat) na + +> import qualified Music.Theory.List as T +> import Sound.SC3.Plot +> plot_p2_stp [T.histogram (map scale_degree db)] + +> import Data.List + +> 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 + +> let r = ["LaMonte Young, tuning of For Guitar '58. 1/1 March '92, inv.of Mersenne lute 1" +> ,"LaMonte Young's Well-Tuned Piano"] +> in filter (isInfixOf "LaMonte Young") (map scale_description db) == r + +> length (filter (not . perfect_octave) db) == 663 + +-} +scl_load_dir :: (Read i, Integral i) => FilePath -> IO [Scale i] +scl_load_dir d = T.dir_subset [".scl"] d >>= mapM scl_load + +-- | Load Scala data base at 'scl_get_dir'. -- --- > 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 +-- > db <- scl_load_db +-- > mapM_ (putStrLn.unlines.scale_stat) (filter (not . perfect_octave) db) +scl_load_db :: (Read i, Integral i) => IO [Scale i] +scl_load_db = do + dir <- scl_get_dir + r <- mapM scl_load_dir dir + return (concat r) + +-- * PP + +scale_stat :: (Integral i,Show i) => Scale i -> [String] +scale_stat s = + let ty = uniform_pitch_type (scale_pitches s) + in ["scale-name : " ++ scale_name s + ,"scale-description : " ++ scale_description s + ,"scale-degree : " ++ show (scale_degree s) + ,"scale-type : " ++ maybe "non-uniform" show ty + ,"perfect-octave : " ++ show (perfect_octave s) + ,"scale-cents-i : " ++ show (scale_cents_i s) + ,if ty == Just Pitch_Ratio + then "scale-ratios : " ++ intercalate "," (map T.rational_pp (scale_ratios_req s)) + else ""] + +-- | Pretty print 'Pitch' in @Scala@ format. +pitch_pp :: Show i => Pitch i -> String +pitch_pp p = + case p of + Left c -> show c + Right r -> show (numerator r) ++ "/" ++ show (denominator r) + +-- | Pretty print 'Scale' in @Scala@ format. -- --- > length (filter (not . perfect_octave) db) == 544 +-- > s <- scl_load "et19" +-- > s <- scl_load "young-lm_piano" +-- > putStr $ unlines $ scale_pp s +scale_pp :: Show i => Scale i -> [String] +scale_pp (nm,dsc,k,p) = + ["! " ++ nm ++ ".scl" + ,"!" + ,dsc + ,show k + ,"!"] ++ map pitch_pp p + +-- * DIST + +-- | @scala@ distribution directory, given at @SCALA_DIST_DIR@. -- --- > 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 +-- > fmap (== "/home/rohan/opt/build/scala-22-pc64-linux") dist_get_dir +dist_get_dir :: IO String +dist_get_dir = getEnv "SCALA_DIST_DIR" --- Local Variables: --- truncate-lines:t --- End: +-- | Load file from 'dist_get_dir'. +-- +-- > s <- load_dist_file "intnam.par" +-- > length s == 473 +load_dist_file :: FilePath -> IO [String] +load_dist_file nm = do + d <- dist_get_dir + fmap lines (readFile (d nm)) diff --git a/Music/Theory/Tuning/Scala/Interval.hs b/Music/Theory/Tuning/Scala/Interval.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Interval.hs @@ -0,0 +1,62 @@ +-- | Parser for the @intnam.par@ file. +module Music.Theory.Tuning.Scala.Interval where + +import Data.Char {- base -} +import Data.List {- base -} + +import qualified Music.Theory.Read as T {- hmt -} +import qualified Music.Theory.Tuning.Scala as T + +-- | Interval and name, ie. (3/2,"perfect fifth") +type INTERVAL = (Rational,String) + +-- | Length prefixed list of 'INTERVAL'. +type INTNAM = (Int,[INTERVAL]) + +-- | Lookup ratio in 'INTNAM'. +-- +-- > db <- load_intnam +-- > intnam_search_ratio db (3/2) == Just (3/2,"perfect fifth") +-- > intnam_search_ratio db (2/3) == Nothing +-- > intnam_search_ratio db (4/3) == Just (4/3,"perfect fourth") +-- > map (intnam_search_ratio db) [3/2,4/3,7/4,7/6,9/7,12/7,14/9] +-- > intnam_search_ratio db (31/16) == Just (31/16,"31st harmonic") +intnam_search_ratio :: INTNAM -> Rational -> Maybe INTERVAL +intnam_search_ratio (_,i) x = find ((== x) . fst) i + +-- | Lookup interval name in 'INTNAM', ci = case-insensitive. +-- +-- > db <- load_intnam +-- > intnam_search_description_ci db "didymus" +intnam_search_description_ci :: INTNAM -> String -> [INTERVAL] +intnam_search_description_ci (_,i) x = + let downcase = map toLower + x' = downcase x + in filter (isInfixOf x' . downcase . snd) i + +-- * Parser + +parse_intnam_entry :: [String] -> INTERVAL +parse_intnam_entry w = + case w of + r:w' -> (T.read_ratio_with_div_err r,unwords w') + _ -> error "parse_intnam_entry" + +parse_intnam :: [String] -> INTNAM +parse_intnam l = + case l of + _:n:i -> let n' = read n :: Int + i' = map (parse_intnam_entry . words) i + in if n' == length i' then (n',i') else error "parse_intnam" + _ -> error "parse_intnam" + +-- * IO + +-- | 'parse_intnam' of 'T.load_dist_file' of "intnam.par". +-- +-- > intnam <- load_intnam +-- > fst intnam == length (snd intnam) +load_intnam :: IO INTNAM +load_intnam = do + l <- T.load_dist_file "intnam.par" + return (parse_intnam (T.filter_comments l)) diff --git a/Music/Theory/Tuning/Scala/Mode.hs b/Music/Theory/Tuning/Scala/Mode.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Mode.hs @@ -0,0 +1,117 @@ +-- | Parser for the @modename.par@ file. +module Music.Theory.Tuning.Scala.Mode where + +import Data.Char {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Function as T +import qualified Music.Theory.List as T +import qualified Music.Theory.Tuning.Scala as T + +-- | (start-degree,intervals,description) +type MODE = (Int,[Int],String) + +mode_starting_degree :: MODE -> Int +mode_starting_degree (d,_,_) = d + +mode_intervals :: MODE -> [Int] +mode_intervals (_,i,_) = i + +mode_description :: MODE -> String +mode_description (_,_,d) = d + +mode_degree :: MODE -> Int +mode_degree = sum . mode_intervals + +-- | (mode-count,_,mode-list) +type MODENAM = (Int,Int,[MODE]) + +modenam_modes :: MODENAM -> [MODE] +modenam_modes (_,_,m) = m + +-- | Search for mode by interval list. +modenam_search_seq :: MODENAM -> [Int] -> [MODE] +modenam_search_seq (_,_,m) x = filter ((== x) . mode_intervals) m + +-- | Expect /one/ result. +-- +-- > mn <- load_modenam +-- > let sq = putStrLn . unlines . mode_stat . fromJust . modenam_search_seq1 mn +-- > sq [2,2,1,2,2,2,1] +-- > sq [2,1,2,2,1,2,2] +-- > sq [2,1,2,2,1,3,1] +-- > sq (replicate 6 2) +-- > sq [1,2,1,2,1,2,1,2] +-- > sq [2,1,2,1,2,1,2,1] +-- > sq (replicate 12 1) +modenam_search_seq1 :: MODENAM -> [Int] -> Maybe MODE +modenam_search_seq1 mn = T.unlist1 . modenam_search_seq mn + +-- | Search for mode by description text. +-- +-- > map (modenam_search_description mn) ["Messiaen","Xenakis","Raga"] +modenam_search_description :: MODENAM -> String -> [MODE] +modenam_search_description (_,_,m) x = filter (isInfixOf x . mode_description) m + +-- | Pretty printer. +mode_stat :: MODE -> [String] +mode_stat (d,i,s) = + ["mode-start-degree : " ++ show d + ,"mode-intervals : " ++ intercalate "," (map show i) + ,"mode-degree : " ++ show (sum i) + ,"mode-description : " ++ s] + +-- * Parser + +-- | Bracketed integers are a non-implicit starting degree. +-- +-- > map non_implicit_degree ["4","[4]"] == [Nothing,Just 4] +non_implicit_degree :: String -> Maybe Int +non_implicit_degree s = + case T.unbracket s of + Just ('[',s',']') -> Just (read s') + _ -> Nothing + +is_non_implicit_degree :: String -> Bool +is_non_implicit_degree = isJust . non_implicit_degree + +is_integer :: String -> Bool +is_integer = all isDigit + +parse_modenam_entry :: [String] -> MODE +parse_modenam_entry w = + let (n0:n,c) = span (T.predicate_or is_non_implicit_degree is_integer) w + in case non_implicit_degree n0 of + Nothing -> (0,map read (n0:n),unwords c) + Just d -> (d,map read n,unwords c) + +-- | Lines ending with @\@ continue to next line. +join_long_lines :: [String] -> [String] +join_long_lines l = + case l of + p:q:l' -> case T.separate_last' p of + (p',Just '\\') -> join_long_lines ((p' ++ q) : l') + _ -> p : join_long_lines (q : l') + _ -> l + +parse_modenam :: [String] -> MODENAM +parse_modenam l = + case l of + n:x:m -> let n' = read n :: Int + x' = read x :: Int + m' = map (parse_modenam_entry . words) m + in if n' == length m' then (n',x',m') else error "parse_modenam" + _ -> error "parse_modenam" + +-- * IO + +-- | 'parse_modenam' of 'T.load_dist_file' of @modenam.par@. +-- +-- > mn <- load_modenam +-- > let (n,x,m) = mn +-- > n == 2125 && x == 15 && length m == n +load_modenam :: IO MODENAM +load_modenam = do + l <- T.load_dist_file "modenam.par" + return (parse_modenam (T.filter_comments (join_long_lines l))) diff --git a/Music/Theory/Tuning/Sethares_1994.hs b/Music/Theory/Tuning/Sethares_1994.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Sethares_1994.hs @@ -0,0 +1,39 @@ +-- | William A. Sethares. +-- "Adaptive Tunings for Musical Scales". +-- /Journal of the Acoustical Society of America/, 96(1), July 1994. +-- +-- +module Music.Theory.Tuning.Sethares_1994 where + +import qualified Music.Theory.Tuning as T + +-- > import Sound.SC3.Plot +-- > plotTable1 (map (\f -> d (220,1) (f,1)) [220 .. 440]) +d :: (Floating n, Ord n) => (n,n) -> (n,n) -> n +d (f1,v1) (f2,v2) = + let d_star = 0.24 + s1 = 0.0207 + s2 = 18.96 + c1 = 5 + c2 = -5 + a1 = -3.51 + a2 = -5.75 + s = d_star / (s1 * min f1 f2 + s2) + f_dif = abs (f2 - f1) + e1 = c1 * exp (a1 * s * f_dif) + e2 = c2 * exp (a2 * s * f_dif) + in v1 * v2 * (e1 + e2) + +-- > plotTable fig_1 +fig_1 :: (Floating n,Enum n,Ord n) => [[n]] +fig_1 = + let f0 = [125,250,500,1000,2000] + r_seq = map T.cents_to_ratio [0 .. 1200] + in map (\f -> map (\r -> d (f,1) (f * r,1)) r_seq) f0 + +-- > let a_seq = take 7 (iterate (* 0.88) 1.0) +-- > let gen f0 = zipWith (\r a -> (f0 * r,a)) [1 .. 7] a_seq +-- > let r_seq = map T.cents_to_ratio [0,1 .. 1200] +-- > plotTable1 (let f0 = 880 in map (\r -> d_h (gen f0) (gen (f0 * r))) r_seq) +d_h :: (Floating n, Ord n) => [(n,n)] -> [(n,n)] -> n +d_h s1 s2 = sum [d p q | p <- s1, q <- s2] diff --git a/Music/Theory/Tuning/Werckmeister.hs b/Music/Theory/Tuning/Werckmeister.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Werckmeister.hs +++ /dev/null @@ -1,105 +0,0 @@ --- | 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 - diff --git a/Music/Theory/Tuple.hs b/Music/Theory/Tuple.hs --- a/Music/Theory/Tuple.hs +++ b/Music/Theory/Tuple.hs @@ -6,9 +6,7 @@ -- Heterogenous tuples (products) are prefixed @p2_@ etc. module Music.Theory.Tuple where -import Data.Monoid {- base -} - --- * P2 (2 product) +-- * P2 (2-product) p2_swap :: (s,t) -> (t,s) p2_swap (i,j) = (j,i) @@ -18,11 +16,11 @@ -- | Uniform two-tuple. type T2 a = (a,a) -t2 :: [t] -> T2 t -t2 l = case l of {[p,q] -> (p,q);_ -> error "t2"} +t2_from_list :: [t] -> T2 t +t2_from_list l = case l of {[p,q] -> (p,q);_ -> error "t2_from_list"} -t2_list :: T2 a -> [a] -t2_list (i,j) = [i,j] +t2_to_list :: T2 a -> [a] +t2_to_list (i,j) = [i,j] t2_swap :: T2 t -> T2 t t2_swap = p2_swap @@ -48,7 +46,7 @@ t2_sort :: Ord t => (t,t) -> (t,t) t2_sort (p,q) = (min p q,max p q) --- * P3 (3 product) +-- * P3 (3-product) -- | Left rotation. -- @@ -69,9 +67,12 @@ type T3 a = (a,a,a) -t3 :: [t] -> T3 t -t3 l = case l of {[p,q,r] -> (p,q,r);_ -> error "t3"} +t3_from_list :: [t] -> T3 t +t3_from_list l = case l of {[p,q,r] -> (p,q,r);_ -> error "t3_from_list"} +t3_to_list :: T3 a -> [a] +t3_to_list (i,j,k) = [i,j,k] + t3_rotate_left :: T3 t -> T3 t t3_rotate_left = p3_rotate_left @@ -89,8 +90,6 @@ 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 @@ -98,7 +97,7 @@ t3_join :: T3 [a] -> [a] t3_join = t3_infix (++) --- * P4 (4 product) +-- * P4 (4-product) p4_fst :: (a,b,c,d) -> a p4_fst (a,_,_,_) = a @@ -116,11 +115,11 @@ 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_from_list :: [t] -> T4 t +t4_from_list l = case l of {[p,q,r,s] -> (p,q,r,s); _ -> error "t4_from_list"} -t4_list :: T4 t -> [t] -t4_list (p,q,r,s) = [p,q,r,s] +t4_to_list :: T4 t -> [t] +t4_to_list (p,q,r,s) = [p,q,r,s] t4_fst :: T4 t -> t t4_fst = p4_fst @@ -146,7 +145,7 @@ t4_join :: T4 [a] -> [a] t4_join = t4_infix (++) --- * P5 (5 product) +-- * P5 (5-product) p5_fst :: (a,b,c,d,e) -> a p5_fst (a,_,_,_,_) = a @@ -163,15 +162,25 @@ p5_fifth :: (a,b,c,d,e) -> e p5_fifth (_,_,_,_,e) = e +p5_from_list :: (t -> t1, t -> t2, t -> t3, t -> t4, t -> t5) -> [t] -> (t1,t2,t3,t4,t5) +p5_from_list (f1,f2,f3,f4,f5) l = + case l of + [c1,c2,c3,c4,c5] -> (f1 c1,f2 c2,f3 c3,f4 c4,f5 c5) + _ -> error "p5_from_list" + + +p5_to_list :: (t1 -> t, t2 -> t, t3 -> t, t4 -> t, t5 -> t) -> (t1, t2, t3, t4, t5) -> [t] +p5_to_list (f1,f2,f3,f4,f5) (c1,c2,c3,c4,c5) = [f1 c1,f2 c2,f3 c3,f4 c4,f5 c5] + -- * 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_from_list :: [t] -> T5 t +t5_from_list l = case l of {[p,q,r,s,t] -> (p,q,r,s,t); _ -> error "t5_from_list"} -t5_list :: T5 t -> [t] -t5_list (p,q,r,s,t) = [p,q,r,s,t] +t5_to_list :: T5 t -> [t] +t5_to_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) @@ -194,7 +203,7 @@ t5_join :: T5 [a] -> [a] t5_join = t5_infix (++) --- * P6 (6 product) +-- * P6 (6-product) p6_fst :: (a,b,c,d,e,f) -> a p6_fst (a,_,_,_,_,_) = a @@ -218,11 +227,11 @@ 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_from_list :: [t] -> T6 t +t6_from_list l = case l of {[p,q,r,s,t,u] -> (p,q,r,s,t,u);_ -> error "t6_from_list"} -t6_list :: T6 t -> [t] -t6_list (p,q,r,s,t,u) = [p,q,r,s,t,u] +t6_to_list :: T6 t -> [t] +t6_to_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) @@ -231,8 +240,8 @@ 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_to_list :: T7 t -> [t] +t7_to_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) @@ -241,18 +250,70 @@ 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_to_list :: T8 t -> [t] +t8_to_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) +-- * P8 (8-product) + +p8_third :: (a,b,c,d,e,f,g,h) -> c +p8_third (_,_,c,_,_,_,_,_) = c + -- * 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_to_list :: T9 t -> [t] +t9_to_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) + +-- * T10 (10-tuple, regular) + +type T10 a = (a,a,a,a,a,a,a,a,a,a) + +t10_to_list :: T10 t -> [t] +t10_to_list (p,q,r,s,t,u,v,w,x,y) = [p,q,r,s,t,u,v,w,x,y] + +t10_map :: (p -> q) -> T10 p -> T10 q +t10_map f (p,q,r,s,t,u,v,w,x,y) = (f p,f q,f r,f s,f t,f u,f v,f w,f x,f y) + +-- * T11 (11-tuple, regular) + +type T11 a = (a,a,a,a,a,a,a,a,a,a,a) + +t11_to_list :: T11 t -> [t] +t11_to_list (p,q,r,s,t,u,v,w,x,y,z) = [p,q,r,s,t,u,v,w,x,y,z] + +t11_map :: (p -> q) -> T11 p -> T11 q +t11_map f (p,q,r,s,t,u,v,w,x,y,z) = (f p,f q,f r,f s,f t,f u,f v,f w,f x,f y,f z) + +-- * T12 (12-tuple, regular) + +type T12 t = (t,t,t,t,t,t,t,t,t,t,t,t) + +t12_to_list :: T12 t -> [t] +t12_to_list (p,q,r,s,t,u,v,w,x,y,z,a) = [p,q,r,s,t,u,v,w,x,y,z,a] + +t12_from_list :: [t] -> T12 t +t12_from_list l = + case l of + [p,q,r,s,t,u,v,w,x,y,z,a] -> (p,q,r,s,t,u,v,w,x,y,z,a) + _ -> error "t12_from_list" + +-- | 'foldr1' of 't12_to_list'. +-- +-- > t12_foldr1 (+) (1,2,3,4,5,6,7,8,9,10,11,12) == 78 +t12_foldr1 :: (t -> t -> t) -> T12 t -> t +t12_foldr1 f = foldr1 f . t12_to_list + +-- | 'sum' of 't12_to_list'. +-- +-- > t12_sum (1,2,3,4,5,6,7,8,9,10,11,12) == 78 +t12_sum :: Num n => T12 n -> n +t12_sum t = + let (n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12) = t + in n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8 + n9 + n10 + n11 + n12 diff --git a/Music/Theory/Unicode.hs b/Music/Theory/Unicode.hs --- a/Music/Theory/Unicode.hs +++ b/Music/Theory/Unicode.hs @@ -1,15 +1,56 @@ -- | +-- +-- These symbols are in , +-- debian=ttf-freefont. module Music.Theory.Unicode where -type Unicode_Table = [(Int,String)] +import Data.List {- base -} +import Numeric {- base -} --- > putStrLn (map (toEnum . fst) (concat unicode)) +import qualified Text.CSV.Lazy.String as C {- lazy-csv -} + +import qualified Music.Theory.IO as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Read as T {- hmt -} + +-- * Non-music + +-- | Unicode non breaking hypen character. +-- +-- > non_breaking_hypen == '‑' +non_breaking_hypen :: Char +non_breaking_hypen = toEnum 0x2011 + +-- | Unicode non breaking space character. +-- +-- > non_breaking_space == ' ' +non_breaking_space :: Char +non_breaking_space = toEnum 0x00A0 + +-- * Music + +type Unicode_Index = Int +type Unicode_Range = (Unicode_Index,Unicode_Index) +type Unicode_Point = (Unicode_Index,String) +type Unicode_Table = [Unicode_Point] + +-- > putStrLn$ map (toEnum . fst) (concat unicode) unicode :: [Unicode_Table] unicode = [accidentals,notes,rests,clefs] +-- > putStrLn$ concatMap (unicode_table_hs . flip unicode_table_block tbl) accidentals_rng_set +accidentals_rng_set :: [Unicode_Range] +accidentals_rng_set = [(0x266D,0x266F),(0x1D12A,0x1D133)] + +-- | UNICODE accidental symbols. +-- +-- > let r = "♭♮♯𝄪𝄫𝄬𝄭𝄮𝄯𝄰𝄱𝄲𝄳" in map (toEnum . fst) accidentals == r accidentals :: Unicode_Table accidentals = - [(0x1D12A,"MUSICAL SYMBOL DOUBLE SHARP") + [(0x266D,"MUSIC FLAT SIGN") + ,(0x266E,"MUSIC NATURAL SIGN") + ,(0x266F,"MUSIC SHARP SIGN") + ,(0x1D12A,"MUSICAL SYMBOL DOUBLE SHARP") ,(0x1D12B,"MUSICAL SYMBOL DOUBLE FLAT") ,(0x1D12C,"MUSICAL SYMBOL FLAT UP") ,(0x1D12D,"MUSICAL SYMBOL FLAT DOWN") @@ -20,6 +61,13 @@ ,(0x1D132,"MUSICAL SYMBOL QUARTER TONE SHARP") ,(0x1D133,"MUSICAL SYMBOL QUARTER TONE FLAT")] +-- > putStrLn$ unicode_table_hs (unicode_table_block notes_rng tbl) +notes_rng :: Unicode_Range +notes_rng = (0x1D15C,0x1D164) + +-- | UNICODE note duration symbols. +-- +-- > let r = "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲" in map (toEnum . fst) notes == r notes :: Unicode_Table notes = [(0x1D15C,"MUSICAL SYMBOL BREVE") @@ -32,6 +80,13 @@ ,(0x1D163,"MUSICAL SYMBOL SIXTY-FOURTH NOTE") ,(0x1D164,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE")] +-- > putStrLn$ unicode_table_hs (unicode_table_block rests_rng tbl) +rests_rng :: Unicode_Range +rests_rng = (0x1D13B,0x1D142) + +-- | UNICODE rest symbols. +-- +-- > let r = "𝄻𝄼𝄽𝄾𝄿𝅀𝅁𝅂" in map (toEnum . fst) rests == r rests :: Unicode_Table rests = [(0x1D13B,"MUSICAL SYMBOL WHOLE REST") @@ -43,6 +98,17 @@ ,(0x1D141,"MUSICAL SYMBOL SIXTY-FOURTH REST") ,(0x1D142,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH REST")] +-- > map toEnum [0x1D15E,0x1D16D,0x1D16D] == "𝅗𝅥𝅭𝅭" +augmentation_dot :: Unicode_Point +augmentation_dot = (0x1D16D, "MUSICAL SYMBOL COMBINING AUGMENTATION DOT") + +-- > putStrLn$ unicode_table_hs (unicode_table_block clefs_rng tbl) +clefs_rng :: Unicode_Range +clefs_rng = (0x1D11E,0x1D126) + +-- | UNICODE clef symbols. +-- +-- > let r = "𝄞𝄟𝄠𝄡𝄢𝄣𝄤𝄥𝄦" in map (toEnum . fst) clefs == r clefs :: Unicode_Table clefs = [(0x1D11E,"MUSICAL SYMBOL G CLEF") @@ -54,3 +120,120 @@ ,(0x1D124,"MUSICAL SYMBOL F CLEF OTTAVA BASSA") ,(0x1D125,"MUSICAL SYMBOL DRUM CLEF-1") ,(0x1D126,"MUSICAL SYMBOL DRUM CLEF-2")] + +-- > putStrLn$ unicode_table_hs (unicode_table_block tbl notehead_rng) +notehead_rng :: Unicode_Range +notehead_rng = (0x1D143,0x1D15B) + +-- | UNICODE notehead symbols. +-- +-- > let r = "𝅃𝅄𝅅𝅆𝅇𝅈𝅉𝅊𝅋𝅌𝅍𝅎𝅏𝅐𝅑𝅒𝅓𝅔𝅕𝅖𝅗𝅘𝅙𝅚𝅛" in map (toEnum . fst) noteheads == r +noteheads :: Unicode_Table +noteheads = + [(0x1d143,"MUSICAL SYMBOL X NOTEHEAD") + ,(0x1d144,"MUSICAL SYMBOL PLUS NOTEHEAD") + ,(0x1d145,"MUSICAL SYMBOL CIRCLE X NOTEHEAD") + ,(0x1d146,"MUSICAL SYMBOL SQUARE NOTEHEAD WHITE") + ,(0x1d147,"MUSICAL SYMBOL SQUARE NOTEHEAD BLACK") + ,(0x1d148,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP WHITE") + ,(0x1d149,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP BLACK") + ,(0x1d14a,"MUSICAL SYMBOL TRIANGLE NOTEHEAD LEFT WHITE") + ,(0x1d14b,"MUSICAL SYMBOL TRIANGLE NOTEHEAD LEFT BLACK") + ,(0x1d14c,"MUSICAL SYMBOL TRIANGLE NOTEHEAD RIGHT WHITE") + ,(0x1d14d,"MUSICAL SYMBOL TRIANGLE NOTEHEAD RIGHT BLACK") + ,(0x1d14e,"MUSICAL SYMBOL TRIANGLE NOTEHEAD DOWN WHITE") + ,(0x1d14f,"MUSICAL SYMBOL TRIANGLE NOTEHEAD DOWN BLACK") + ,(0x1d150,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP RIGHT WHITE") + ,(0x1d151,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP RIGHT BLACK") + ,(0x1d152,"MUSICAL SYMBOL MOON NOTEHEAD WHITE") + ,(0x1d153,"MUSICAL SYMBOL MOON NOTEHEAD BLACK") + ,(0x1d154,"MUSICAL SYMBOL TRIANGLE-ROUND NOTEHEAD DOWN WHITE") + ,(0x1d155,"MUSICAL SYMBOL TRIANGLE-ROUND NOTEHEAD DOWN BLACK") + ,(0x1d156,"MUSICAL SYMBOL PARENTHESIS NOTEHEAD") + ,(0x1d157,"MUSICAL SYMBOL VOID NOTEHEAD") + ,(0x1d158,"MUSICAL SYMBOL NOTEHEAD BLACK") + ,(0x1d159,"MUSICAL SYMBOL NULL NOTEHEAD") + ,(0x1d15a,"MUSICAL SYMBOL CLUSTER NOTEHEAD WHITE") + ,(0x1d15b,"MUSICAL SYMBOL CLUSTER NOTEHEAD BLACK")] + +-- > map toEnum [0x1D143,0x1D165] == "𝅃𝅥" +stem :: Unicode_Point +stem = (0x1D165, "MUSICAL SYMBOL COMBINING STEM") + +-- > putStrLn$ unicode_table_hs (unicode_table_block dynamics_rng tbl) +dynamics_rng :: Unicode_Range +dynamics_rng = (0x1D18C,0x1D193) + +-- > map (toEnum . fst) dynamics == "𝆌𝆍𝆎𝆏𝆐𝆑𝆒𝆓" +dynamics :: Unicode_Table +dynamics = + [(0x1d18c,"MUSICAL SYMBOL RINFORZANDO") + ,(0x1d18d,"MUSICAL SYMBOL SUBITO") + ,(0x1d18e,"MUSICAL SYMBOL Z") + ,(0x1d18f,"MUSICAL SYMBOL PIANO") + ,(0x1d190,"MUSICAL SYMBOL MEZZO") + ,(0x1d191,"MUSICAL SYMBOL FORTE") + ,(0x1d192,"MUSICAL SYMBOL CRESCENDO") + ,(0x1d193,"MUSICAL SYMBOL DECRESCENDO")] + +-- > putStrLn$ unicode_table_hs (unicode_table_block articulations_rng tbl) +articulations_rng :: Unicode_Range +articulations_rng = (0x1D17B,0x1D18B) + +-- > putStrLn (map (toEnum . fst) articulations :: String) +articulations :: Unicode_Table +articulations = + [(0x1d17b,"MUSICAL SYMBOL COMBINING ACCENT") + ,(0x1d17c,"MUSICAL SYMBOL COMBINING STACCATO") + ,(0x1d17d,"MUSICAL SYMBOL COMBINING TENUTO") + ,(0x1d17e,"MUSICAL SYMBOL COMBINING STACCATISSIMO") + ,(0x1d17f,"MUSICAL SYMBOL COMBINING MARCATO") + ,(0x1d180,"MUSICAL SYMBOL COMBINING MARCATO-STACCATO") + ,(0x1d181,"MUSICAL SYMBOL COMBINING ACCENT-STACCATO") + ,(0x1d182,"MUSICAL SYMBOL COMBINING LOURE") + ,(0x1d183,"MUSICAL SYMBOL ARPEGGIATO UP") + ,(0x1d184,"MUSICAL SYMBOL ARPEGGIATO DOWN") + ,(0x1d185,"MUSICAL SYMBOL COMBINING DOIT") + ,(0x1d186,"MUSICAL SYMBOL COMBINING RIP") + ,(0x1d187,"MUSICAL SYMBOL COMBINING FLIP") + ,(0x1d188,"MUSICAL SYMBOL COMBINING SMEAR") + ,(0x1d189,"MUSICAL SYMBOL COMBINING BEND") + ,(0x1d18a,"MUSICAL SYMBOL COMBINING DOUBLE TONGUE") + ,(0x1d18b,"MUSICAL SYMBOL COMBINING TRIPLE TONGUE")] + +-- * Blocks + +type Unicode_Block = (Unicode_Range,String) + +-- > putStrLn$ unicode_table_hs (concatMap (flip unicode_table_block tbl . fst) unicode_blocks) +unicode_blocks :: [Unicode_Block] +unicode_blocks = + [((0x1B00,0x1B7F),"Balinese") + ,((0x2200,0x22FF),"Mathematical Operators") + ,((0x25A0,0x25FF),"Geometric Shapes") + ,((0x1D000,0x1D0FF),"Byzantine Musical Symbols") + ,((0x1D100,0x1D1FF),"Musical Symbols") + ,((0x1D200,0x1D24F),"Ancient Greek Musical Notation")] + +-- * Table + +-- | +-- +-- > let fn = "/home/rohan/data/unicode.org/Public/8.0.0/ucd/UnicodeData.txt" +-- > tbl <- unicode_data_table_read fn +-- > length tbl == 29215 +unicode_data_table_read :: FilePath -> IO Unicode_Table +unicode_data_table_read fn = do + s <- T.read_file_utf8 fn + let t = C.fromCSVTable (C.csvTable (C.parseDSV False ';' s)) + f x = (T.read_hex_err (x !! 0),x !! 1) + return (map f t) + +unicode_table_block :: (Int,Int) -> Unicode_Table -> Unicode_Table +unicode_table_block (l,r) = takeWhile ((<= r) . fst) . dropWhile ((< l) . fst) + +unicode_point_hs :: Unicode_Point -> String +unicode_point_hs (n,s) = concat ["(0x",showHex n "",",\"",s,"\")"] + +unicode_table_hs :: Unicode_Table -> String +unicode_table_hs = T.bracket ('[',']') . intercalate "," . map unicode_point_hs diff --git a/Music/Theory/Wyschnegradsky.hs b/Music/Theory/Wyschnegradsky.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Wyschnegradsky.hs @@ -0,0 +1,331 @@ +-- | +module Music.Theory.Wyschnegradsky where + +import Data.Char {- base -} +import Data.List {- list -} +import Data.List.Split {- split -} +import Data.Maybe {- base -} + +import Music.Theory.List {- hmt -} +import Music.Theory.Pitch {- hmt -} +import Music.Theory.Pitch.Spelling.Table {- hmt -} + +-- | In a modulo /m/ system, normalise step increments to be either -1 +-- or 1. Non steps raise an error. +-- +-- > map (normalise_step 6) [-5,-1,1,5] == [1,-1,1,-1] +normalise_step :: (Eq n,Num n) => n -> n -> n +normalise_step m n + | n == 1 = 1 + | n == -1 = -1 + | n == m - 1 = -1 + | n == 1 - m = 1 + | otherwise = error "normalise_step" + +-- | Wyschnegradsky writes the direction sign at the end of the number. +-- +-- > map parse_num_sign ["2+","4-"] == [2,-4] +parse_num_sign :: (Num n, Read n) => String -> n +parse_num_sign s = + case separate_last s of + (n,'+') -> read n + (n,'-') -> negate (read n) + _ -> error "parse_num_sign" + +-- | Expand a chromatic (step-wise) sequence, sign indicates direction. +-- +-- > map vec_expand [2,-4] == [[1,1],[-1,-1,-1,-1]] +vec_expand :: Num n => Int -> [n] +vec_expand n = if n > 0 then replicate n 1 else replicate (abs n) (-1) + +-- | Parse the vector notation used in some drawings, a comma +-- separated list of chromatic sequences. +-- +-- > parse_vec Nothing 0 "4-,4+,4-,4+,4-,4+,4-,4+,4-" +-- > parse_vec Nothing 0 "2+,2-,2+,2-,2+,2-,2+,2-,2+,18+" +parse_vec :: Num n => Maybe Int -> n -> String -> [n] +parse_vec n m = + let f = case n of + Just i -> dx_d m . take i . cycle + Nothing -> dx_d m + in dropRight 1 . f . concatMap (vec_expand . parse_num_sign) . splitOn "," + +-- | Modulo addition. +add_m :: Integral a => a -> a -> a -> a +add_m n p q = (p + q) `mod` n + +-- | Parse hex colour string, as standard in HTML5. +-- +-- > parse_hex_clr "#e14630" == (225,70,48) +parse_hex_clr :: (Read n,Num n) => String -> (n,n,n) +parse_hex_clr clr = + let f p q = read ("0x" ++ [p,q]) + in case clr of + ['#',p,q,r,s,t,u] -> (f p q,f r s,f t u) + _ -> error "parse_hex" + +-- | Type specialised. +parse_hex_clr_int :: String -> (Int,Int,Int) +parse_hex_clr_int = parse_hex_clr + +-- | Normalise colour by dividing each component by /m/. +-- +-- > clr_normalise 255 (parse_hex_clr "#ff0066") == (1,0,0.4) +clr_normalise :: (Real r,Fractional f) => f -> (r,r,r) -> (f,f,f) +clr_normalise m (r,g,b) = let f x = realToFrac x / m in (f r,f g,f b) + +-- | Sequences are either in 'Radial' or 'Circumferential' order. +data Seq a = Radial [a] | Circumferential [a] + +-- | Group sequence into normal (ie. 'Circumferential') order given +-- drawing dimensions. +seq_group :: Int -> Int -> Seq a -> [[a]] +seq_group c_div r_div s = + case s of + Circumferential c -> chunksOf c_div c + Radial r -> transpose (chunksOf r_div r) + +-- | Printer for pitch-class segments. +iw_pc_pp :: Integral n => String -> [[n]] -> IO () +iw_pc_pp sep = + let f = pitch_pp_opt (False,False) . octpc_to_pitch pc_spell_ks . (,) 4 + in putStrLn . intercalate sep . map (unwords . map f) + +-- * U3 + +-- | Index to colour name abbreviation. +-- +-- > map u3_ix_ch [0..5] == "ROYGBV" +u3_ix_ch :: Integral i => i -> Char +u3_ix_ch = genericIndex "ROYGBV" . (`mod` 6) + +-- | Inverse of 'u3_ix_ch'. +-- +-- > map u3_ch_ix "ROYGBV" == [0..5] +u3_ch_ix :: Char -> Int +u3_ch_ix = fromMaybe (error "u3_ch_ix") . flip elemIndex "ROYGBV" + +-- | Drawing definition, as written by Wyschnegradsky. +-- +-- > mapM_ (\(c,r) -> putStrLn (unlines ["C: " ++ c,"R: " ++ r])) u3_vec_text_iw +u3_vec_text_iw :: [(String, String)] +u3_vec_text_iw = + [("4+,4-,4+,4-,2+" + ,"4-,4+,4-,4+,4-,4+,4-,4+,4-") + ,("9+,2+,2-,2+,2-,2+" + ,"2+,2-,2+,2-,2+,2-,2+,2-,2+,18+") + ,("12-,12+,12-" + ,"18+,18-") + ,("3+,3-,3+,3-,3+,3-" + ,"18+,18-") + ,("9+,9-" + ,"3+,3-,3+,3-,3+,3-,3+,3-,3+,3-,3+,3-") + ,("2+,2-,2+,2-,2+,2-" + ,"6-,6+,6-,6+,6-,6+") + ,("2+,2-,2+,2-,2+,2-" + ,"6+,6-,6+,6-,6+,6-") + ,("6+,6-" + ,"2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-")] + +-- | Re-written for local parser and to correct ambiguities and errors +-- (to align with actual drawing). +-- +-- > let f = parse_vec Nothing 0 in map (\(p,q) -> (f p,f q)) u3_vec_text_rw +-- +-- > let f (c,r) = putStrLn (unlines ["C: " ++ c,"R: " ++ r]) +-- > in mapM_ f (interleave u3_vec_text_iw u3_vec_text_rw) +u3_vec_text_rw :: [(String, String)] +u3_vec_text_rw = + [("4+,3-,5+,3-,3+" + ,"4-,3+,5-,3+,5-,3+,5-,3+,5-") -- 1 + ,("9+,2+,1-,3+,1-,2+" + ,"2+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,2-") -- 2 + ,("12-,12+,12-" + ,"18+,18-") + ,("3+,2-,4+,2-,4+,3-" + ,"18+,18-") + ,("9+,9-" + ,"3+,2-,4+,1-,1+,1-,3+,1-,1+,1-,3+,2-,4+,1-,1+,1-,3+,1-,1+,1-") -- 5 + ,("2+,1-,3+,1-,3+,2-" + ,"6-,6+,6-,6+,6-,6+") -- 6 + ,("2+,1-,3+,1-,3+,2-" + ,"6+,6-,6+,6-,6+,6-") -- 7 + ,("6+,6-" + ,"2+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,2-")] -- 8 + +-- | Parse of 'u3_vec_text_rw'. +-- +-- > let {(c,r) = u3_vec_ix ; c' = map length c} +-- > in (length c,c',sum c',length r,map length r) +u3_vec_ix :: Num n => ([[n]],[[n]]) +u3_vec_ix = + let f (p,q) = [parse_vec Nothing 0 p,parse_vec Nothing 0 q] + [c,r] = transpose (map f u3_vec_text_rw) + in (c,r) + +-- | Radial indices (ie. each /ray/ as an index sequence). +-- +-- > putStrLn $ unlines $ map (map u3_ix_ch) u3_ix_radial +u3_ix_radial :: Integral n => [[n]] +u3_ix_radial = + let (c,r) = u3_vec_ix + r' = zipWith replicate (map length c) r + in zipWith (\p q -> map (add_m 6 p) q) (concat c) (concat r') + +-- | Colour names in index sequence. +u3_clr_nm :: [String] +u3_clr_nm = words "red orange yellow green blue violet" + +-- | Colour values (hex strings) in index sequence. +u3_clr_hex :: [String] +u3_clr_hex = words "#e14630 #e06e30 #e2c48e #498b43 #2a5a64 #cb7b74" + +-- | RGB form of 'u3_clr_hex'. +u3_clr_rgb :: Fractional n => [(n,n,n)] +u3_clr_rgb = map (clr_normalise 256 . parse_hex_clr_int) u3_clr_hex + +-- | Notated radial color sequence, transcribed from drawing. +-- +-- > map (\(n,c) -> let v = u3_ch_seq_to_vec c in (n,sum v,v)) u3_radial_ch +u3_radial_ch :: [(Int,[Char])] +u3_radial_ch = + [(1,"RVBGY GBV BGYOR OYG YORVB VRO RVBGY GBVBGYO") + ,(5,"ROYG YO YGBV BV BVRO RO ROYG YO YGBV BV BVR OR O")] + +-- | Notated circumferenctial color sequence, transcribed from drawing. +-- +-- > map (\(n,c) -> (n,u3_ch_seq_to_vec c)) u3_circ_ch +u3_circ_ch :: [(Int,[Char])] +u3_circ_ch = + [(6,"ROYOYGBGBVRV") + ,(7,"ROYOYGBGBVRV") + ,(8,"ROYGBVRVBGYO")] + +-- | Translate notated sequence to "re-written" vector notation. +u3_ch_seq_to_vec :: [Char] -> [Int] +u3_ch_seq_to_vec = + map length . + group . + map (normalise_step 6) . + d_dx . + map u3_ch_ix . + filter (not . isSpace) + +-- * DC9 + +{- | Circumference pitch classes, C = 0. + +> let c' = map length dc9_circ in (sum c',c') == (72,[5,6,7,2,3,4,4,3,2,7,7,4,4,3,2,2,3,4]) + +> iw_pc_pp " | " dc9_circ + +-} +dc9_circ :: Num n => [[n]] +dc9_circ = + [[6,5,4,3,2] + ,[3,2,1,0,11,10] + ,[11,10,9,8,7,6,5] + ,[6,5] + ,[6,5,4] + ,[5,4,3,2] + ,[3,2,1,0] + ,[1,0,11] + ,[0,11] + ,[0,1,2,3,4,5,6] + ,[5,6,7,8,9,10,9] + ,[10,11,0,1] + ,[0,1,2,3] + ,[2,3,4] + ,[3,4] + ,[3,4] + ,[3,4,5] + ,[4,5,6,7]] + +-- | Rayon pitch classes, C = 0. +-- +-- > length dc9_rad == 18 +-- > putStrLn $ unwords $ map f dc9_rad +dc9_rad :: Num n => [n] +dc9_rad = [0,10,8,6,4,2,0,10,8,6,4,2,0,10,8,6,4,2] + +-- | Radial indices. +-- +-- > map length dc9_ix == replicate 72 18 +dc9_ix :: Integral n => [[n]] +dc9_ix = map (\n -> map (add_m 12 n) dc9_rad) (concat dc9_circ) + +-- | Approximate colours, hex strings. +dc9_clr_hex :: [String] +dc9_clr_hex = + let c = ["#e96d61","#e6572b" + ,"#e07122","#e39e36" + ,"#e8b623","#e5c928" + ,"#c2ba3d","#a2a367" + ,"#537a77","#203342" + ,"#84525e","#bc6460"] + n = interleave [6,4,2,0,10,8] [5,3,1,11,9,7] :: [Int] + in map snd (sort (zip n c)) + +-- | RGB form of colours. +dc9_clr_rgb :: Fractional n => [(n,n,n)] +dc9_clr_rgb = map (clr_normalise 255 . parse_hex_clr_int) dc9_clr_hex + +-- * U11 + +-- > 18 * 4 == 72 +-- > let c' = map length u11_circ in (sum c',length c',c') +-- +-- > iw_pc_pp "\n- " u11_circ +u11_circ :: Num n => [[n]] +u11_circ = + [[7,8,9,10,11,0,1,2,3] + ,[10,11,0,1,2,3,4,5,6] + ,[0,1,2,3,4,5] + ,[0,1,2] + ,[10,11] + ,[6,7] + ,[2] + ,[9] + ,[4] + ,[11] + ,[6,7] + ,[2] + ,[9] + ,[2] + ,[11] + ,[6,7] + ,[2,3] + ,[10,11,0] + ,[7,8,9,10,11,0] + ,[7,8,9,10,11,0,1,2,3] + ,[10,11,0,1,2,3,4,5,6]] + +-- > iw_pc_pp "|" [u11_gen_seq 7 18 [5]] +u11_gen_seq :: Integral i => i -> Int -> [i] -> [i] +u11_gen_seq z n = map (`mod` 12) . take n . dx_d z . cycle + +u11_seq_rule :: Integral i => Maybe Int -> [i] +u11_seq_rule n = u11_gen_seq 0 18 (maybe [-1] (\x -> replicate x (-1) ++ [5]) n) + +-- > ull_rad_text == "012588---------885210" +ull_rad_text :: [Char] +ull_rad_text = + let x = "012588----" + y = "-" + in x ++ y ++ reverse x + +-- > iw_pc_pp "\n- " u11_rad +u11_rad :: Integral n => [[n]] +u11_rad = + let f c = if c == '-' then Nothing else Just (read [c]) + in map (u11_seq_rule . f) ull_rad_text + +u11_clr_hex :: [String] +u11_clr_hex = + let c = ["#dbb56a","#ffb05c","#ea7c3f","#f93829","#ee6054","#d18d9c" + ,"#a94c79","#215272","#628b7d","#9dbc90","#ecdfaa","#fbeaa5"] + n = reverse ([4..11] ++ [0..3]) :: [Int] + in map snd (sort (zip n c)) + +u11_clr_rgb :: Fractional n => [(n,n,n)] +u11_clr_rgb = map (clr_normalise 256 . parse_hex_clr_int) u11_clr_hex diff --git a/Music/Theory/Xenakis/S4.hs b/Music/Theory/Xenakis/S4.hs --- a/Music/Theory/Xenakis/S4.hs +++ b/Music/Theory/Xenakis/S4.hs @@ -49,12 +49,12 @@ case sort x of [1,2,3,4] -> x [5,6,7,8] -> complement x - _ -> error "lower" + _ -> error (show ("lower",x)) -- | Application of 'Label' /p/ on /q/. -- -- > l_on Q1 I == Q1 --- > l_on D A == G +-- > l_on D Q12 == Q4 -- > [l_on L L,l_on E D,l_on D E] == [L2,C,B] l_on :: Label -> Label -> Label l_on p q = @@ -63,6 +63,48 @@ r = map (\i -> q' !! (i - 1)) p' in label_of r +{- | Generalisation of Fibonnaci process, /f/ is the binary operator +giving the next element, /p/ and /q/ are the initial elements. + +See discussion in: Carlos Agon, Moreno Andreatta, Gérard Assayag, and +Stéphan Schaub. _Formal Aspects of Iannis Xenakis' "Symbolic Music": A +Computer-Aided Exploration of Compositional Processes_. Journal of New +Music Research, 33(2):145-159, 2004. + +Note that the article has an error, printing Q4 for Q11 in the sequence below. + +> import qualified Music.Theory.List as T + +> let r = [D,Q12,Q4, E,Q8,Q2, E2,Q7,Q4, D2,Q3,Q11, L2,Q7,Q2, L,Q8,Q11] +> in (take 18 (fib_proc l_on D Q12) == r,T.duplicates r == [Q2,Q4,Q7,Q8,Q11]) + +Beginning E then G2 no Q nodes are visited. + +> let r = [E,G2,L2,C,G,D,E,B,D2,L,G,C,L2,E2,D2,B] +> in (take 16 (fib_proc l_on E G2) == r,T.duplicates r == [B,C,D2,E,G,L2]) + +> import Music.Theory.List +> let [a,b] = take 2 (segments 18 18 (fib_proc l_on D Q12)) in a == b + +The prime numbers that are not factors of 18 are {1,5,7,11,13,17}. +They form a closed group under modulo 18 multiplication. + +> let {n = [5,7,11,13,17] +> ;r = [(5,7,17),(5,11,1),(5,13,11),(5,17,13) +> ,(7,11,5),(7,13,1),(7,17,11) +> ,(11,13,17),(11,17,7) +> ,(13,17,5)]} +> in [(p,q,(p * q) `mod` 18) | p <- n, q <- n, p < q] == r + +The article also omits the 5 after 5,1 in the sequence below. + +> let r = [11,13,17,5,13,11,17,7,11,5,1,5,5,7,17,11,7,5,17,13,5,11,1,11] +> in take 24 (fib_proc (\p q -> (p * q) `mod` 18) 11 13) == r + +-} +fib_proc :: (a -> a -> a) -> a -> a -> [a] +fib_proc f p q = let r = f p q in p : fib_proc f q r + -- | 'Seq' of 'Label', inverse of 'label_of'. -- -- > seq_of Q1 == [8,7,5,6,4,3,1,2] @@ -186,42 +228,56 @@ -- * Figures --- | Fig. VIII-6. Hexahedral (Octahedral) Group (p. 220) +-- | Label sequence of 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 = +-- > let r = [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 viii_6_lseq == r +viii_6_lseq :: [Label] +viii_6_lseq = [L2,L,A,Q1,Q7,Q3,Q9 ,G2,G,C,Q8,Q5,Q10,Q2 ,E,E2,B,Q4,Q11,Q12,Q6 ,D,D2,I] +-- | Label sequence of Fig. VIII-7 (p.221) +-- +-- > let r = [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 viii_7_lseq == r +viii_7_lseq :: [Label] +viii_7_lseq = + [I,A,B,C + ,D,D2,E,E2 + ,G,G2,L,L2 + ,Q1,Q2,Q3,Q4 + ,Q5,Q6,Q7,Q8 + ,Q9,Q10,Q11,Q12] + -- | 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]] +-- +-- > import Music.Theory.Array.MD +-- +-- > let t = md_matrix_opt show (\x -> "_" ++ x ++ "_") (head viii_7,head viii_7) viii_7 +-- > putStrLn $ unlines $ md_table' t 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 +viii_7 = map (\i -> map (`l_on` i) viii_7_lseq) viii_7_lseq --- | Fig. VIII-6/b 'Labels' (p.221) +-- | Label sequence of Fig. VIII-6/b (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] +viii_6b_lseq :: [Label] +viii_6b_lseq = + [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'. -- @@ -258,7 +314,7 @@ -- | Variant of 'viii_6b' with 'Half_Seq'. viii_6b' :: [(Label,Half_Seq)] -viii_6b' = zip viii_6b_l viii_6b_p' +viii_6b' = zip viii_6b_lseq viii_6b_p' -- | Fig. VIII-6/b. -- @@ -266,19 +322,19 @@ -- > ,(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') +viii_6b = zip viii_6b_lseq (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) +viii_6_relations = relations (map half_seq_of viii_6_lseq) -- | 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) +viii_6b_relations = relations (map half_seq_of viii_6b_lseq) diff --git a/Music/Theory/Xenakis/Sieve.hs b/Music/Theory/Xenakis/Sieve.hs --- a/Music/Theory/Xenakis/Sieve.hs +++ b/Music/Theory/Xenakis/Sieve.hs @@ -14,6 +14,7 @@ | 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 + | Complement Sieve -- ^ 'Complement' of a 'Sieve' deriving (Eq,Show) -- | The 'Union' of a list of 'Sieve's, ie. 'foldl1' 'Union'. @@ -32,6 +33,20 @@ (∩) :: Sieve -> Sieve -> Sieve (∩) = Intersection +-- | Synonym for 'Complement'. +c :: Sieve -> Sieve +c = Complement + +-- | Pretty-print sieve. Fully parenthesised. +sieve_pp :: Sieve -> String +sieve_pp s = + case s of + Empty -> "∅" + L (p,q) -> concat [show p,".",show q] + Union p q -> concat ["(",sieve_pp p," ∪ ",sieve_pp q,")"] + Intersection p q -> concat ["(",sieve_pp p," ∩ ",sieve_pp q,")"] + Complement p -> concat ["(∁ ",sieve_pp p,")"] + -- | Variant of 'L', ie. 'curry' 'L'. -- -- > l 15 19 == L (15,19) @@ -49,6 +64,7 @@ -- | In a /normal/ 'Sieve' /m/ is '>' /i/. -- -- > normalise (L (15,19)) == L (15,4) +-- > normalise (L (11,13)) == L (11,2) normalise :: Sieve -> Sieve normalise s = case s of @@ -56,10 +72,12 @@ L (m,i) -> L (m,i `mod` m) Union s0 s1 -> Union (normalise s0) (normalise s1) Intersection s0 s1 -> Intersection (normalise s0) (normalise s1) + Complement s' -> Complement (normalise s') -- | Predicate to test if a 'Sieve' is /normal/. -- -- > is_normal (L (15,4)) == True +-- > is_normal (L (11,13)) == False is_normal :: Sieve -> Bool is_normal s = s == normalise s @@ -74,7 +92,19 @@ 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 + Complement s' -> not (element s' n) +-- > take 9 (i_complement [1,3..]) == [0,2..16] +i_complement :: [I] -> [I] +i_complement = + let f x s = case s of + [] -> [x ..] + e:s' -> case compare x e of + LT -> x : f (x + 1) s + EQ -> f (x + 1) s' + GT -> error "i_complement" + in f 0 + -- | Construct the sequence defined by a 'Sieve'. Note that building -- a sieve that contains an intersection clause that has no elements -- gives @_|_@. @@ -93,6 +123,7 @@ 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)) + Complement s' -> i_complement (build s') {- | Variant of 'build' that gives the first /n/ places of the 'reduce' of 'Sieve'. @@ -124,6 +155,77 @@ > 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 +Agon et. al. p.155 + +> let {a = c (13⋄3 ∪ 13⋄5 ∪ 13⋄7 ∪ 13⋄9) +> ;b = 11⋄2 +> ;c' = c (11⋄4 ∪ 11⋄8) +> ;d = 13⋄9 +> ;e = 13⋄0 ∪ 13⋄1 ∪ 13⋄6 +> ;f = (a ∩ b) ∪ (c' ∩ d) ∪ e} +> in buildn 13 f == [0,1,2,6,9,13,14,19,22,24,26,27,32] + +> differentiate [0,1,2,6,9,13,14,19,22,24,26,27,32] == [1,1,4,3,4,1,5,3,2,2,1,5] + +> import Music.Theory.Pitch + +> let {n = [0,1,2,6,9,13,14,19,22,24,26,27,32] +> ;r = "C C𝄲 C♯ D♯ E𝄲 F𝄰 G A𝄲 B C C♯ C𝄰 E"} +> in unwords (map (pitch_class_pp . pc24et_to_pitch . (`mod` 24)) n) == r + +Jonchaies + +> let s = map (17⋄) [0,1,4,5,7,11,12,16] +> in differentiate (buildn 25 (union s)) + +Nekuïa + +> let s = [24⋄0,14⋄2,22⋄3,31⋄4,28⋄7,29⋄9,19⋄10,25⋄13,24⋄14,26⋄17,23⋄21 +> ,24⋄10,30⋄9,35⋄17,29⋄24,32⋄25,30⋄29,26⋄21,30⋄17,31⋄16] +> in differentiate (buildn 24 (union s)) + +Major scale: + +> let s = (c(3⋄2) ∩ 4⋄0) ∪ (c(3⋄1) ∩ 4⋄1) ∪ (3⋄2 ∩ 4⋄2) ∪ (c(3⋄0) ∩ 4⋄3) +> in buildn 7 s == [0,2,4,5,7,9,11] + +Nomos Alpha: + +let {s = (c (13⋄3 ∪ 13⋄5 ∪ 13⋄7 ∪ 13⋄9) ∩ 11⋄2) ∪ (c (11⋄4 ∪ 11⋄8) ∩ 13⋄9) ∪ (13⋄0 ∪ 13⋄1 ∪ 13⋄6) + ;r = [0,1,2,6,9,13,14,19,22,24,26,27,32,35,39,40,45,52,53,58,61,65,66,71,78,79,84,87,90,91,92,97]} +in buildn 32 s == r + +/Psappha/ (Flint): + +> let {s = union [(8⋄0∪8⋄1∪8⋄7)∩(5⋄1∪5⋄3) +> ,(8⋄0∪8⋄1∪8⋄2)∩5⋄0 +> ,8⋄3∩(5⋄0∪5⋄1∪5⋄2∪5⋄3∪5⋄4) +> ,8⋄4∩(5⋄0∪5⋄1∪5⋄2∪5⋄3∪5⋄4) +> ,(8⋄5∪8⋄6)∩(5⋄2∪5⋄3∪5⋄4) +> ,8⋄1∩5⋄2 +> ,8⋄6∩5⋄1] +> ;r = [0,1,3,4,6,8,10,11,12 +> ,13,14,16,17,19,20,22,23,25 +> ,27,28,29,31,33,35,36,37,38]} +> in buildn 27 s == r + +À R. (Hommage à Maurice Ravel) (Squibbs, 1996) + +> let {s = union [8⋄0∩(11⋄0∪11⋄4∪11⋄5∪11⋄6∪11⋄10) +> ,8⋄1∩(11⋄2∪11⋄3∪11⋄6∪11⋄7∪11⋄9) +> ,8⋄2∩(11⋄0∪11⋄1∪11⋄2∪11⋄3∪11⋄5∪11⋄10) +> ,8⋄3∩(11⋄1∪11⋄2∪11⋄3∪11⋄4∪11⋄10) +> ,8⋄4∩(11⋄0∪11⋄4∪11⋄8) +> ,8⋄5∩(11⋄0∪11⋄2∪11⋄3∪11⋄7∪11⋄9∪11⋄10) +> ,8⋄6∩(11⋄1∪11⋄3∪11⋄5∪11⋄7∪11⋄8∪11⋄9) +> ,8⋄7∩(11⋄1∪11⋄3∪11⋄6∪11⋄7∪11⋄8∪11⋄10)] +> ;r = [0,2,3,4,7,9,10,13,14,16 +> ,17,21,23,25,29,30,32,34,35,38 +> ,39,43,44,47,48,52,53,57,58,59 +> ,62,63,66,67,69,72,73,77,78,82 +> ,86,87]} +> in buildn 42 s == r + -} buildn :: Int -> Sieve -> [I] buildn n = take n . build . reduce @@ -183,6 +285,8 @@ -- > 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) -- +-- > putStrLn $ sieve_pp (reduce s) +-- -- > 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 @@ -202,3 +306,4 @@ Intersection s1 Empty -> s1 Intersection (L p) (L q) -> maybe Empty L (reduce_intersection p q) Intersection s1 s2 -> f Intersection s1 s2 + Complement s' -> Complement (reduce s') diff --git a/Music/Theory/Z.hs b/Music/Theory/Z.hs --- a/Music/Theory/Z.hs +++ b/Music/Theory/Z.hs @@ -1,94 +1,147 @@ --- | Generalised Z-/n/ functions. +-- | Z-/n/ functions with modulo function as parameter. module Music.Theory.Z where -{- - -From GHC 7.6 onwards there is the modular-arithmetic package, which subsumes this work. - -{-# Language DataKinds #-} +import Data.Char {- base -} +import Data.List {- base -} -import Data.Modular {- modular-arithmetic -} -import GHC.TypeLits {- base -} +import qualified Music.Theory.List as T {- hmt -} -type Z n = Mod Integer n +-- | The modulo function for Z. +type Z t = (t -> t) --- > 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 +-- | Is /n/ in (0,/m/-1). +is_z_n :: (Num a, Ord a) => a -> a -> Bool +is_z_n m n = n >= 0 && n < m --- > 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 +mod5 :: Integral i => Z i +mod5 n = n `mod` 5 --} +mod7 :: Integral i => Z i +mod7 n = n `mod` 7 -import Data.List {- base -} +mod12 :: Integral i => Z i +mod12 n = n `mod` 12 -lift_unary_Z :: Integral a => a -> (t -> a) -> t -> a -lift_unary_Z z f n = mod (f n) z +lift_unary_Z :: Z i -> (t -> i) -> t -> i +lift_unary_Z z f n = z (f n) -lift_binary_Z :: Integral a => a -> (s -> t -> a) -> s -> t -> a -lift_binary_Z z f n1 n2 = mod (n1 `f` n2) z +lift_binary_Z :: Z i -> (s -> t -> i) -> s -> t -> i +lift_binary_Z z f n1 n2 = z (n1 `f` n2) -- > 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 id (11::Z12.Z12) 5 == 4 +-- > (11::Z12.Z12) + 5 == 4 +-- > map (z_add mod12 4) [1,5,6] == [5,9,10] +z_add :: Integral i => Z i -> i -> i -> i z_add z = lift_binary_Z z (+) -z_sub :: Integral a => a -> a -> a -> a +-- | The underlying type /i/ is presumed to be signed... +-- +-- > z_sub mod12 0 8 == 4 +-- +-- > import Data.Word +-- > z_sub mod12 (0::Word8) 8 == 8 +-- > ((0 - 8) :: Word8) == 248 +-- > 248 `mod` 12 == 8 +z_sub :: Integral i => Z i -> i -> i -> i z_sub z = lift_binary_Z z (-) -z_mul :: Integral a => a -> a -> a -> a +{- | Allowing unsigned /i/ is rather inefficient... +z_sub :: Integral i => Z i -> i -> i -> i +z_sub z p q = + if p > q + then z (p - q) + else let m = z_modulus z + in z (p + m - q) +-} + +z_mul :: Integral i => Z i -> i -> i -> i z_mul z = lift_binary_Z z (*) -z_negate :: Integral a => a -> a -> a -z_negate z = lift_unary_Z z negate +-- > z_negate mod12 7 == 5 +z_negate :: Integral i => Z i -> i -> i +z_negate z = z_sub z 0 -- error "Z numbers are not signed" -z_fromInteger :: Integral a => a -> Integer -> a -z_fromInteger z i = fromInteger i `mod` z +z_fromInteger :: Integral i => Z i -> Integer -> i +z_fromInteger z i = z (fromInteger i) -z_signum :: t -> t1 -> t2 +z_signum :: t -> u -> v z_signum _ _ = error "Z numbers are not signed" -z_abs :: t -> t1 -> t2 +z_abs :: t -> u -> v 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 +-- > map (to_Z mod12) [-9,-3,0] == [3,9,0] +to_Z :: Integral i => Z 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. +-- | Modulus of /z/. -- --- > 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_modulus mod12 == 12 +z_modulus :: Integral i => Z i -> i +z_modulus z = maybe (error "z_modulus") (fromIntegral . (+ 1)) (findIndex ((== 0) . z) [1..]) -z_quot :: Integral i => i -> i -> i -> i +-- | Universe of 'Z'. +-- +-- > z_univ mod12 == [0..11] +z_univ :: Integral i => Z i -> [i] +z_univ z = 0 : takeWhile ((> 0) . z) [1..] + +-- | Z of 'z_univ' not in given set. +-- +-- > z_complement mod5 [0,2,3] == [1,4] +-- > z_complement mod12 [0,2,4,5,7,9,11] == [1,3,6,8,10] +z_complement :: Integral i => Z i -> [i] -> [i] +z_complement z = (\\) (z_univ z) + +z_quot :: Integral i => Z i -> i -> i -> i z_quot z p = to_Z z . quot p -z_rem :: Integral c => c -> c -> c -> c +z_rem :: Integral i => Z i -> i -> i -> i 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 +div_err :: Integral i => String -> i -> i -> i +div_err s p q = if q == 0 then error ("div_err: zero" ++ s) else p `div` q --- > z_mod 12 6 12 -z_mod :: Integral c => c -> c -> c -> c +z_div :: Integral i => Z i -> i -> i -> i +z_div z p = to_Z z . div_err "z_div" p + +-- > z_mod mod12 6 12 == 6 +z_mod :: Integral i => Z i -> i -> i -> i z_mod z p = to_Z z . mod p -z_quotRem :: Integral t => t -> t -> t -> (t, t) +z_quotRem :: Integral i => Z i -> i -> i -> (i,i) 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 :: Integral i => Z i -> i -> i -> (i,i) z_divMod z p q = (z_div z p q,z_mod z p q) -z_toInteger :: Integral i => i -> i -> i +z_toInteger :: Integral i => Z i -> i -> i z_toInteger z = to_Z z + +-- * Z16 + +mod16 :: Integral i => Z i +mod16 n = n `mod` 16 + +integral_to_digit :: Integral t => t -> Char +integral_to_digit = intToDigit . fromIntegral + +is_z16 :: Integral t => t -> Bool +is_z16 = is_z_n 16 + +z16_to_char :: Integral t => t -> Char +z16_to_char = integral_to_digit + +z16_set_pp :: Integral t => [t] -> String +z16_set_pp = T.bracket ('{','}') . map z16_to_char + +z16_seq_pp :: Integral t => [t] -> String +z16_seq_pp = T.bracket ('<','>') . map z16_to_char + +z16_vec_pp :: Integral t => [t] -> String +z16_vec_pp = T.bracket ('[',']') . map z16_to_char diff --git a/Music/Theory/Z/Boros_1990.hs b/Music/Theory/Z/Boros_1990.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Boros_1990.hs @@ -0,0 +1,296 @@ +-- | James Boros. "Some Properties of the All-Trichord Hexachord". +-- _In Theory Only_, 11(6):19--41, 1990. +module Music.Theory.Z.Boros_1990 where + +import Data.Char {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Numeric {- base -} + +import qualified Data.Graph.Inductive.Graph as G {- fgl -} +import qualified Data.Graph.Inductive.Basic as G {- fgl -} +import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -} +import qualified Data.Graph.Inductive.Query.BFS as G {- fgl -} + +import qualified Music.Theory.Array.MD as T +import qualified Music.Theory.Combinations as T +import qualified Music.Theory.Graph.Dot as T +import qualified Music.Theory.Graph.FGL as T +import qualified Music.Theory.List as T +import qualified Music.Theory.Set.List as T +import qualified Music.Theory.Tuple as T +import qualified Music.Theory.Z as T +import qualified Music.Theory.Z.Forte_1973 as T +import qualified Music.Theory.Z.TTO as T + +-- * UTIL + +singular :: String -> [t] -> t +singular err l = + case l of + [x] -> x + _ -> error ("not singular: " ++ err) + +set_eq :: Ord t => [t] -> [t] -> Bool +set_eq p q = T.set p == T.set q + +elem_by :: (t -> t -> Bool) -> t -> [t] -> Bool +elem_by f e = any (f e) + +-- * TTO + +tto_tni_univ :: Integral i => [T.TTO i] +tto_tni_univ = filter (not . T.tto_M) (T.z_tto_univ T.mod12) + +all_tn :: Integral i => [i] -> [[i]] +all_tn p = map (\n -> map (T.z_add T.mod12 n) p) [0..11] + +all_tni :: Integral i => [i] -> [[i]] +all_tni p = map (\f -> T.z_tto_apply 5 T.mod12 f p) tto_tni_univ + +uniq_tni :: Integral i => [i] -> [[i]] +uniq_tni = nub . all_tni + +type PC = Int +type PCSET = [PC] +type SC = PCSET + +pcset_trs :: Int -> PCSET -> PCSET +pcset_trs n p = sort (map (T.mod12 . (+ n)) p) + +-- | Forte prime forms of the twelve trichordal set classes. +-- +-- > length trichords == 12 +trichords :: [PCSET] +trichords = filter ((== 3) . length) (T.sc_univ T.mod12) + +-- | Is a pcset self-inversional, ie. is the inversion of /p/ a transposition of /p/. +-- +-- > map (\p -> (p,self_inv p)) trichords +self_inv :: PCSET -> Bool +self_inv p = elem_by set_eq (map (T.z_negate T.mod12) p) (all_tn p) + +-- | Pretty printer, comma separated. +-- +-- > pcset_pp [0,3,7,10] == "0,3,7,10" +pcset_pp :: PCSET -> String +pcset_pp = intercalate "," . map show + +-- | Pretty printer, hexadecimal, no separator. +-- +-- > pcset_pp_hex [0,3,7,10] == "037A" +pcset_pp_hex :: PCSET -> String +pcset_pp_hex = map toUpper . concat . map (flip showHex "") + +-- * ATH + +-- | Forte prime form of the all-trichord hexachord. +-- +-- > T.sc_name T.mod12 ath == "6-Z17" +-- > T.sc "6-Z17" == ath +ath :: PCSET +ath = [0,1,2,4,7,8] + +-- | Is /p/ an instance of 'ath'. +is_ath :: PCSET -> Bool +is_ath p = T.forte_prime T.mod12 p == ath + +-- | Table 1, p.20 +-- +-- > length ath_univ == 24 +ath_univ :: [PCSET] +ath_univ = uniq_tni ath + +-- | Calculate 'T.TTO' of pcset, which must be an instance of 'ath'. +-- +-- > ath_tni [1,2,3,7,8,11] == T.TTO 3 False True +ath_tni :: PCSET -> T.TTO PC +ath_tni = singular "ath_tni" . filter (not . T.tto_M) . T.z_tto_rel 5 T.mod12 ath + +-- | Give label for instance of 'ath', prime forms are written H and inversions h. +-- +-- > ath_pp [1,2,3,7,8,11] == "h3" +ath_pp :: PCSET -> String +ath_pp p = + let r = ath_tni p + h = if T.tto_I r then 'h' else 'H' + in h : show (T.tto_T r) + +-- | The twenty three-element subsets of 'ath'. +-- +-- > length ath_trichords == 20 +ath_trichords :: [PCSET] +ath_trichords = T.combinations (3::Int) ath + +-- | '\\' of 'ath' and /p/, ie. the pitch classes that are in 'ath' and not in /p/. +-- +-- > ath_complement [0,1,2] == [4,7,8] +ath_complement :: PCSET -> PCSET +ath_complement p = ath \\ p + +-- | /p/ is a pcset, /q/ a sc, calculate pcsets in /q/ that with /p/ form 'ath'. +-- +-- > ath_completions [0,1,2] (T.sc "3-3") == [[6,7,10],[4,7,8]] +-- > ath_completions [6,7,10] (T.sc "3-5") == [[1,2,8]] +ath_completions :: PCSET -> SC -> [PCSET] +ath_completions p q = + let f z = is_ath (p ++ z) + in filter f (uniq_tni q) + +realise_ath_seq :: [PCSET] -> [[PCSET]] +realise_ath_seq sq = + case sq of + p:q:sq' -> concatMap (\z -> map (p :) (realise_ath_seq (z : sq'))) (ath_completions p q) + _ -> [sq] + +-- return edges that connect z to nodes at gr in an ATH relation +ath_gr_extend :: T.GRAPH PCSET -> PCSET -> [T.EDGE PCSET] +ath_gr_extend gr c = + let f x y = if is_ath (x ++ y) then Just (x,y) else Nothing + g (p,q) = mapMaybe (f c) [p,q] + in nub (map T.t2_sort (concatMap g gr)) + +gr_trs :: Int -> T.GRAPH PCSET -> T.GRAPH PCSET +gr_trs n = let f (p,q) = (pcset_trs n p,pcset_trs n q) in map f + +-- * TABLES + +-- > length table_3 == 20 +table_3 :: [((PCSET,SC,T.SC_Name),(PCSET,SC,T.SC_Name))] +table_3 = + let f p = let q = ath_complement p + i x = (x,T.forte_prime T.mod12 x,T.sc_name T.mod12 x) + in (i p,i q) + in map f ath_trichords + +-- > putStrLn $ unlines $ table_3_md +table_3_md :: [String] +table_3_md = + let pp = pcset_pp_hex + f ((p,q,r),(s,t,u)) = [pp p,pp q,r,pp s,pp t,u] + hdr = ["P","P/SC","P/F","Q=H0-P","Q/SC","Q/F"] + in T.md_table' (Just hdr,map f table_3) + +-- > length table_4 == 10 +table_4 :: [((PCSET,PCSET,T.SC_Name),(PCSET,PCSET,T.SC_Name))] +table_4 = nub (map T.t2_sort table_3) + +-- > putStrLn $ unlines $ table_4_md +table_4_md :: [String] +table_4_md = + let pp = pcset_pp_hex + f ((p,q,r),(s,t,u)) = [pp p ++ "/" ++ pp s,pp q ++ "/" ++ pp t,r ++ "/" ++ u] + hdr = ["Trichords","Prime Forms","Forte Numbers"] + in T.md_table' (Just hdr,map f table_4) + +table_5 :: [(PCSET,Int)] +table_5 = T.histogram (map (T.forte_prime T.mod12) ath_trichords) + +-- > putStrLn $ unlines $ table_5_md +table_5_md :: [String] +table_5_md = + let f (p,q) = [pcset_pp_hex p,show q] + in T.md_table' (Just ["SC","#ATH"],map f table_5) + +table_6 :: [(PCSET,Int,Int)] +table_6 = + let f (p,n) = (p,n,length (filter (\q -> p `T.is_subset` q) ath_univ)) + in map f table_5 + +-- > putStrLn $ unlines $ table_6_md +table_6_md :: [String] +table_6_md = + let f (p,q,r) = [pcset_pp_hex p,show q,show r] + in T.md_table' (Just ["SC","#H0","#Hn"],map f table_6) + +-- * FIGURES + +fig_1 :: T.GRAPH PCSET +fig_1 = map (T.t2_map T.p3_snd) table_4 + +fig_1_gr :: G.Gr PCSET () +fig_1_gr = T.g_from_edges fig_1 + +-- > putStrLn $ unlines $ map (unwords . map pcset_pp) fig_2 +fig_2 :: [[PCSET]] +fig_2 = + let g = G.undir fig_1_gr + n = G.labNodes g + n' = filter ((== 2) . G.deg g . fst) n + c = T.combinations (2::Int) n' + p = map (\[lhs,rhs] -> G.esp (fst lhs) (fst rhs) g) c + p' = (filter (not . null) p) + in map (mapMaybe (\x -> lookup x n)) p' + +fig_3 :: [T.GRAPH PCSET] +fig_3 = map (concatMap (T.adj2 1) . realise_ath_seq) fig_2 + +fig_3_gr :: [G.Gr PCSET ()] +fig_3_gr = map T.g_from_edges fig_3 + +fig_4 :: [T.GRAPH PCSET] +fig_4 = + let p = concatMap realise_ath_seq fig_2 + q = filter ([0,1,2] `elem`) p + in map (T.adj2 1) q + +fig_5 :: [T.GRAPH PCSET] +fig_5 = + let c = [0,4,8] + f gr = case ath_gr_extend gr c of + [] -> Nothing + r -> Just (gr ++ r) + g0 = concat fig_4 + in mapMaybe (\n -> f (gr_trs n g0)) [0 .. 11] + +-- * Drawing + +uedge_set :: Ord v => [T.EDGE v] -> [T.EDGE v] +uedge_set = nub . map T.t2_sort + +-- | Self-inversional pcsets are drawn in a double circle, other pcsets in a circle. +set_shape :: PCSET -> String +set_shape v = if self_inv v then "doublecircle" else "circle" + +type GR = G.Gr PCSET () + +gr_pp' :: (PCSET -> String) -> T.GR_PP PCSET () +gr_pp' f = (Just . set_shape,Just . f,const Nothing) + +gr_pp :: T.GR_PP PCSET () +gr_pp = gr_pp' pcset_pp + +d_fig_1 :: [String] +d_fig_1 = T.g_to_udot [] gr_pp fig_1_gr + +d_fig_3_g :: GR +d_fig_3_g = T.g_from_edges (uedge_set (concat fig_3)) + +d_fig_3 :: [String] +d_fig_3 = T.g_to_udot [] gr_pp d_fig_3_g + +d_fig_3' :: [[String]] +d_fig_3' = map (T.g_to_udot [("node:shape","circle")] gr_pp) fig_3_gr + +d_fig_4_g :: GR +d_fig_4_g = T.g_from_edges (uedge_set (concat fig_4)) + +d_fig_4 :: [String] +d_fig_4 = T.g_to_udot [] gr_pp d_fig_4_g + +d_fig_5_g :: GR +d_fig_5_g = T.g_from_edges (uedge_set (concat fig_5)) + +d_fig_5 :: [String] +d_fig_5 = T.g_to_udot [("edge:len","1.5")] (gr_pp' pcset_pp_hex) d_fig_5_g + +d_fig_5_e :: [T.EDGE_L PCSET PCSET] +d_fig_5_e = map (\(p,q) -> ((p,q),p++q)) (uedge_set (concat fig_5)) + +d_fig_5_g' :: G.Gr PCSET PCSET +d_fig_5_g' = T.g_from_edges_l d_fig_5_e + +d_fig_5' :: [String] +d_fig_5' = + let pp = (const (Just ""),const Nothing,Just . ath_pp) + in T.g_to_udot [("node:shape","point"),("edge:len","1.25")] pp d_fig_5_g' diff --git a/Music/Theory/Z/Clough_1979.hs b/Music/Theory/Z/Clough_1979.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Clough_1979.hs @@ -0,0 +1,116 @@ +-- | John Clough. "Aspects of Diatonic Sets". +-- _Journal of Music Theory_, 23(1):45--61, 1979. +module Music.Theory.Z.Clough_1979 where + +import Data.List {- base -} + +import qualified Music.Theory.List as T {- hmt -} + +-- type Z7 = Int + +transpose_to_zero :: Num n => [n] -> [n] +transpose_to_zero p = + case p of + [] -> [] + n:_ -> map (+ (negate n)) p + +-- | Diatonic pitch class (Z7) set to /chord/. +-- +-- > map dpcset_to_chord [[0,1],[0,2,4],[2,3,4,5,6]] == [[1,6],[2,2,3],[1,1,1,1,3]] +dpcset_to_chord :: Integral n => [n] -> [n] +dpcset_to_chord = T.d_dx . (++ [7]) . transpose_to_zero . nub . sort + +-- | Inverse of 'dpcset_to_chord'. +-- +-- > map chord_to_dpcset [[1,6],[2,2,3]] == [[0,1],[0,2,4]] +chord_to_dpcset :: Integral n => [n] -> [n] +chord_to_dpcset = T.dropRight 1 . T.dx_d 0 + +-- | Complement, ie. in relation to 'z7_univ'. +-- +-- > map dpcset_complement [[0,1],[0,2,4]] == [[2,3,4,5,6],[1,3,5,6]] +dpcset_complement :: Integral n => [n] -> [n] +dpcset_complement p = filter (`notElem` p) z7_univ + +-- | Interval class predicate (ie. 'is_z4'). +is_ic :: Integral n => n -> Bool +is_ic n = n >= 0 && n < 4 + +-- | Interval to interval class. +-- +-- > map i_to_ic [0..7] == [0,1,2,3,3,2,1,0] +i_to_ic :: Integral n => n -> n +i_to_ic n = if n > 3 then 7 - n else n + +-- | Is /chord/, ie. is 'sum' @7@. +-- +-- > is_chord [2,2,3] +is_chord :: Integral n => [n] -> Bool +is_chord = (== 7) . sum + +-- | Interval vector. +-- +-- > iv [2,2,3] == [0,2,1] +iv :: Integral n => [n] -> [n] +iv p = + let h = T.generic_histogram p + f n = T.lookup_def n 0 h + in map f [1,2,3] + +-- | Comparison function for 'inv'. +inf_cmp :: Ord a => [a] -> [a] -> Ordering +inf_cmp p q = + if null p && null q + then EQ + else case compare (last p) (last q) of + EQ -> inf_cmp (T.dropRight 1 p) (T.dropRight 1 q) + r -> r + +-- | Interval normal form. +-- +-- > map inf [[2,2,3],[1,2,4],[2,1,4]] == [[2,2,3],[1,2,4],[2,1,4]] +inf :: Integral n => [n] -> [n] +inf = maximumBy inf_cmp . T.rotations + +-- | Inverse of chord (retrograde). +-- +-- > let p = [1,2,4] in (inf p,invert p,inf (invert p)) == ([1,2,4],[4,2,1],[2,1,4]) +invert :: [n] -> [n] +invert = reverse + +-- | Complement of /chord/. +-- +-- > let r = [[1,1,1,1,3],[1,1,1,2,2],[1,1,2,1,2],[1,1,1,4],[2,1,1,3],[1,2,1,3],[1,2,2,2]] +-- > in map complement [[1,6],[2,5],[3,4],[1,1,5],[1,2,4],[1,3,3],[2,2,3]] == r +complement :: Integral n => [n] -> [n] +complement = inf . dpcset_to_chord . dpcset_complement . chord_to_dpcset + +-- | Z7 pitch sequence to Z7 interval sequence, ie. 'mod7' of 'T.d_dx'. +-- +-- > map iseq (permutations [0,1,2]) == [[1,1],[6,2],[6,6],[1,5],[5,1],[2,6]] +-- > map iseq (permutations [0,1,3]) == [[1,2],[6,3],[5,6],[2,4],[4,1],[3,5]] +-- > map iseq (permutations [0,2,3]) == [[2,1],[5,3],[6,5],[1,4],[4,2],[3,6]] +-- > map iseq (permutations [0,1,4]) == [[1,3],[6,4],[4,6],[3,3],[3,1],[4,4]] +-- > map iseq (permutations [0,2,4]) == [[2,2],[5,4],[5,5],[2,3],[3,2],[4,5]] +iseq :: Integral n => [n] -> [n] +iseq = map mod7 . T.d_dx + +-- * Z + +is_z_n :: Integral n => n -> n -> Bool +is_z_n m n = n >= 0 && n < m + +is_z4 :: Integral n => n -> Bool +is_z4 = is_z_n 4 + +z_n_univ :: Integral n => n -> [n] +z_n_univ m = [0 .. m - 1] + +z7_univ :: Integral n => [n] +z7_univ = z_n_univ 7 + +is_z7 :: Integral n => n -> Bool +is_z7 = is_z_n 7 + +mod7 :: Integral n => n -> n +mod7 n = n `mod` 7 diff --git a/Music/Theory/Z/Drape_1999.hs b/Music/Theory/Z/Drape_1999.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Drape_1999.hs @@ -0,0 +1,36 @@ +module Music.Theory.Z.Drape_1999 where + +import Music.Theory.Z +import Music.Theory.Z.SRO +import Music.Theory.Z.TTO + +{- | Relate sets (TnMI). + +>>> $ pct rs 0123 641B +>>> T1M + +> map tto_pp (rs 5 mod12 [0,1,2,3] [6,4,1,11]) == ["T1M","T4MI"] +-} +rs :: Integral t => t -> Z t -> [t] -> [t] -> [TTO t] +rs = z_tto_rel + +{- | Relate segments. + +>>> $ pct rsg 156 3BA +>>> T4I +>>> $ pct rsg 0123 05A3 +>>> T0M +>>> $ pct rsg 0123 4B61 +>>> RT1M +>>> $ pct rsg 0123 B614 +>>> r3RT1M + +> let sros = map sro_parse . words +> rsg 5 mod12 [1,5,6] [3,11,10] == sros "T4I r1RT4MI" +> rsg 5 mod12 [0,1,2,3] [0,5,10,3] == sros "T0M RT3MI" +> rsg 5 mod12 [0,1,2,3] [4,11,6,1] == sros "T4MI RT1M" +> rsg 5 mod12 [0,1,2,3] [11,6,1,4] == sros "r1T4MI r1RT1M" + +-} +rsg :: Integral i => i -> Z i -> [i] -> [i] -> [SRO i] +rsg m z x y = filter (\o -> z_sro_apply m z o x == y) (z_sro_univ (length x) z) diff --git a/Music/Theory/Z/Forte_1973.hs b/Music/Theory/Z/Forte_1973.hs --- a/Music/Theory/Z/Forte_1973.hs +++ b/Music/Theory/Z/Forte_1973.hs @@ -5,87 +5,95 @@ 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 +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Set.List as S {- hmt -} +import Music.Theory.Unicode {- hmt -} +import Music.Theory.Z {- hmt -} +import Music.Theory.Z.SRO {- hmt -} + -- * 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 mod12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]] +t_rotations :: Integral i => Z i -> [i] -> [[i]] t_rotations z p = - let r = rotations (sort p) - in map (tn_to z 0) r + let r = T.rotations (sort p) + in map (z_sro_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 mod12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10] +-- > ,[0,9,11],[0,2,3],[0,1,10]] +ti_rotations :: Integral i => Z i -> [i] -> [[i]] ti_rotations z p = - let q = invert z 0 p - r = rotations (sort p) ++ rotations (sort q) - in map (tn_to z 0) r + let q = z_sro_invert z 0 p + r = T.rotations (sort p) ++ T.rotations (sort q) + in map (z_sro_tn_to z 0) r -- | Variant with default value for empty input list case. -minimumBy_or :: a -> (a -> a -> Ordering) -> [a] -> a +minimumBy_or :: t -> (t -> t -> Ordering) -> [t] -> t 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 :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i] 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 :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i] 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 + case (p,q) of + ([],[]) -> EQ + ([],_) -> LT + (_,[]) -> GT + _ -> 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] +-- > forte_prime mod12 [0,1,3,6,8,9] == [0,1,3,6,8,9] +-- > forte_prime mod5 [0,1,4] == [0,1,2] -- --- > S.set (map (forte_prime 5) (S.powerset [0..4])) -forte_prime :: Integral a => a -> [a] -> [a] +-- > S.set (map (forte_prime mod5) (S.powerset [0..4])) +-- > S.set (map (forte_prime mod7) (S.powerset [0..6])) +forte_prime :: Integral i => Z i -> [i] -> [i] 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] +-- > (forte_prime mod12 [0,2,3],t_prime mod12 [0,2,3]) == ([0,1,3],[0,2,3]) +t_prime :: Integral i => Z i -> [i] -> [i] t_prime z = t_cmp_prime z forte_cmp -- * ICV Metric --- | Interval class of i interval /i/. +-- | Interval class of interval /i/. -- +-- > map (ic 12) [0..11] == [0,1,2,3,4,5,6,5,4,3,2,1] +-- > map (ic 7) [0..6] == [0,1,2,3,3,2,1] -- > 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 +-- > map (ic 12 . to_Z mod12) [-13,-1,0,1,13] == [1,1,0,1,1] +ic :: Integral i => i -> i -> i +ic z i = if i <= (z `div` 2) then i else 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) + let i = map (ic z . flip mod z . uncurry (-)) (S.pairs s) + f l = (head l,genericLength l) 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 @@ -98,4 +106,344 @@ -- -- > 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 +bip z = sort . map (ic z . flip mod z) . T.d_dx + +-- * Name + +{- | Generate SC universe, though not in order of the Forte table. + +> let r = [[] +> ,[0] +> ,[0,1],[0,2],[0,3] +> ,[0,1,2],[0,1,3],[0,1,4],[0,2,4] +> ,[0,1,2,3],[0,1,2,4],[0,1,3,4],[0,1,3,5] +> ,[0,1,2,3,4],[0,1,2,3,5],[0,1,2,4,5] +> ,[0,1,2,3,4,5] +> ,[0,1,2,3,4,5,6]] +> in sc_univ mod7 == r + +> sort (sc_univ mod12) == sort (map snd sc_table) + +> zipWith (\p q -> (p == q,p,q)) (sc_univ mod12) (map snd sc_table) + +-} +sc_univ :: Integral i => Z i -> [[i]] +sc_univ z = + T.sort_by_two_stage length id $ + nub $ + map (forte_prime z) $ + S.powerset (z_univ z) + +-- | Synonym for 'String'. +type SC_Name = String + +-- | The set-class table (Forte prime forms). +-- +-- > length sc_table == 224 +sc_table :: Num n => [(SC_Name,[n])] +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])] + +-- | Unicode (non-breaking hyphen) variant. +sc_table_unicode :: Num n => [(SC_Name,[n])] +sc_table_unicode = + let f = map (\c -> if c == '-' then non_breaking_hypen else c) + in map (\(nm,pc) -> (f nm,pc)) sc_table + +-- | Lookup name of prime form of set class. It is an error for the +-- input not to be a forte prime form. +-- +-- > forte_prime_name [0,1,4,6] == ("4-Z15",[0,1,4,6]) +forte_prime_name :: (Num n,Eq n) => [n] -> (SC_Name,[n]) +forte_prime_name p = fromMaybe (error "forte_prime_name") (find (\(_,q) -> p == q) sc_table) + +sc_tbl_lookup :: Integral i => Z i -> [(SC_Name,[i])] -> [i] -> Maybe (SC_Name,[i]) +sc_tbl_lookup z tbl p = find (\(_,q) -> forte_prime z p == q) tbl + +sc_tbl_lookup_err :: Integral i => Z i -> [(SC_Name,[i])] -> [i] -> (SC_Name,[i]) +sc_tbl_lookup_err z tbl = fromMaybe (error "sc_tbl_lookup") . sc_tbl_lookup z tbl + +sc_name' :: Integral i => Z i -> [(SC_Name,[i])] -> [i] -> SC_Name +sc_name' z tbl = fst . sc_tbl_lookup_err z tbl + +-- | Lookup a set-class name. The input set is subject to +-- 'forte_prime' before lookup. +-- +-- > sc_name mod12 [0,2,3,6,7] == "5-Z18" +-- > sc_name mod12 [0,1,4,6,7,8] == "6-Z17" +sc_name :: Integral i => Z i -> [i] -> SC_Name +sc_name z = sc_name' z sc_table + +-- | Long name (ie. with enumeration of prime form). +-- +-- > sc_name_long mod12 [0,1,4,6,7,8] == "6-Z17[012478]" +sc_name_long :: Integral i => Z i -> [i] -> SC_Name +sc_name_long z p = + let (nm,p') = sc_tbl_lookup_err z sc_table p + in nm ++ z16_vec_pp p' + +-- | Unicode (non-breaking hyphen) variant. +sc_name_unicode :: Integral i => Z i -> [i] -> SC_Name +sc_name_unicode z = sc_name' z sc_table_unicode + +-- | Lookup a set-class given a set-class name. +-- +-- > sc "6-Z17" == [0,1,2,4,7,8] +sc :: Num n => SC_Name -> [n] +sc n = snd (fromMaybe (error "sc") (find (\(m,_) -> n == m) sc_table)) + +scs :: Num n => [[n]] +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, Num n) => i -> [[n]] +scs_n n = filter ((== n) . genericLength) scs + +-- | Vector indicating degree of intersection with inversion at each transposition. +-- +-- > tics mod12 [0,2,4,5,7,9] == [3,2,5,0,5,2,3,4,1,6,1,4] +tics :: Integral i => Z i -> [i] -> [Int] +tics z p = + let q = z_sro_t_related z (z_sro_invert z 0 p) + in map (length . intersect p) q + +-- * Z-relation + +-- | Locate /Z/ relation of set class. +-- +-- > fmap (sc_name mod12) (z_relation_of 12 (sc "7-Z12")) == Just "7-Z36" +z_relation_of :: Integral i => i -> [i] -> Maybe [i] +z_relation_of z x = + let n = length x + eq_i :: [Integer] -> [Integer] -> Bool + eq_i = (==) + f y = (x /= y) && (icv z x `eq_i` icv z y) + in case filter f (scs_n n) of + [] -> Nothing + [r] -> Just r + _ -> error "z_relation_of" diff --git a/Music/Theory/Z/Read_1978.hs b/Music/Theory/Z/Read_1978.hs --- a/Music/Theory/Z/Read_1978.hs +++ b/Music/Theory/Z/Read_1978.hs @@ -5,12 +5,14 @@ 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 -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Z as Z {- hmt -} +import qualified Music.Theory.Z.SRO as Z {- hmt -} + -- | Coding. type Code = Int @@ -45,7 +47,7 @@ -- | 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 +-- > 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 @@ -57,8 +59,8 @@ -- | '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 12 [0,2,3,5] == 2880 +-- > map (set_to_code 12) (T.z_ti_related (flip mod 12) [0,2,3,5]) set_to_code :: Integral i => i -> [i] -> Code set_to_code z = array_to_code . set_to_array z @@ -73,8 +75,9 @@ 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)) + n = length a + z = flip mod n + u = maximum (map (set_to_code n) (Z.z_sro_ti_related z p)) in c == u -- | The augmentation rule adds @1@ in each empty slot at end of array. @@ -114,7 +117,7 @@ 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) + post_proc = map jn . T.group_on fst . sortOn fst in post_proc ((0,[a0]) : f 0 a0) -- * Alternate (reverse) form. @@ -135,10 +138,10 @@ -- | Binary encoding prime form algorithm, equalivalent to Rahn. -- --- > encode_prime 12 [0,1,3,6,8,9] == [0,2,3,6,7,9] +-- > encode_prime Z.mod12 [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 :: Integral i => Z.Z 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)) + let t = map (\x -> Z.z_sro_tn z x s) (Z.z_univ z) + c = t ++ map (Z.z_sro_invert z 0) t + in decode (Z.z_modulus z) (minimum (map encode c)) diff --git a/Music/Theory/Z/SRO.hs b/Music/Theory/Z/SRO.hs --- a/Music/Theory/Z/SRO.hs +++ b/Music/Theory/Z/SRO.hs @@ -2,82 +2,188 @@ module Music.Theory.Z.SRO where import Data.List {- base -} +import qualified Text.ParserCombinators.Parsec as P {- parsec -} +import qualified Music.Theory.List as T +import qualified Music.Theory.Parse as T + import Music.Theory.Z +-- | Serial operator,of the form rRTMI. +data SRO t = SRO {sro_r :: Int + ,sro_R :: Bool + ,sro_T :: t + ,sro_M :: Bool + ,sro_I :: Bool} + deriving (Eq,Show) + +-- | Printer in 'rnRTnMI' form. +sro_pp :: Show t => SRO t -> String +sro_pp (SRO rN r tN m i) = + concat [if rN /= 0 then 'r' : show rN else "" + ,if r then "R" else "" + ,'T' : show tN + ,if m then "M" else "" + ,if i then "I" else ""] + +p_sro :: Integral t => P.GenParser Char () (SRO t) +p_sro = do + let rot = P.option 0 (P.char 'r' >> T.parse_int) + r <- rot + r' <- T.is_char 'R' + _ <- P.char 'T' + t <- T.parse_int + m <- T.is_char 'M' + i <- T.is_char 'I' + P.eof + return (SRO r r' t m i) + +-- | Parse a Morris format serial operator descriptor. +-- +-- > sro_parse "r2RT3MI" == SRO 2 True 3 True True +sro_parse :: Integral i => String -> SRO i +sro_parse = + either (\e -> error ("sro_parse failed\n" ++ show e)) id . + P.parse p_sro "" + +-- | The total set of serial operations. +-- +-- > let u = z_sro_univ 3 mod12 +-- > zip (map sro_pp u) (map (\o -> z_sro_apply 5 mod12 o [0,1,3]) u) +z_sro_univ :: Integral i => Int -> Z i -> [SRO i] +z_sro_univ n_rot z = + [SRO r r' t m i | + r <- [0 .. n_rot - 1], + r' <- [False,True], + t <- z_univ z, + m <- [False,True], + i <- [False,True]] + +-- | The set of transposition 'SRO's. +z_sro_Tn :: Integral i => Z i -> [SRO i] +z_sro_Tn z = [SRO 0 False n False False | n <- z_univ z] + +-- | The set of transposition and inversion 'SRO's. +z_sro_TnI :: Integral i => Z i -> [SRO i] +z_sro_TnI z = + [SRO 0 False n False i | + n <- z_univ z, + i <- [False,True]] + +-- | The set of retrograde and transposition and inversion 'SRO's. +z_sro_RTnI :: Integral i => Z i -> [SRO i] +z_sro_RTnI z = + [SRO 0 r n False i | + r <- [True,False], + n <- z_univ z, + i <- [False,True]] + +-- | The set of transposition, @M5@ and inversion 'SRO's. +z_sro_TnMI :: Integral i => Z i -> [SRO i] +z_sro_TnMI z = + [SRO 0 False n m i | + n <- z_univ z, + m <- [True,False], + i <- [True,False]] + +-- | The set of retrograde,transposition,@M5@ and inversion 'SRO's. +z_sro_RTnMI :: Integral i => Z i -> [SRO i] +z_sro_RTnMI z = + [SRO 0 r n m i | + r <- [True,False], + n <- z_univ z, + m <- [True,False], + i <- [True,False]] + +-- * Serial operations + +-- | Apply SRO. M is ordinarily 5, but can be specified here. +-- +-- > z_sro_apply 5 mod12 (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4] +-- > z_sro_apply 5 mod12 (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4] +z_sro_apply :: Integral i => i -> Z i -> SRO i -> [i] -> [i] +z_sro_apply mn z (SRO r r' t m i) x = + let x1 = if i then z_sro_invert z 0 x else x + x2 = if m then z_sro_mn z mn x1 else x1 + x3 = z_sro_tn z t x2 + x4 = if r' then reverse x3 else x3 + in T.rotate_left r x4 + -- | 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) +-- > z_sro_tn mod5 4 [0,1,4] == [4,0,3] +-- > z_sro_tn mod12 4 [1,5,6] == [5,9,10] +z_sro_tn :: (Integral i, Functor f) => Z i -> i -> f i -> f i +z_sro_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)) +-- > z_sro_invert mod5 0 [0,1,4] == [0,4,1] +-- > z_sro_invert mod12 6 [4,5,6] == [8,7,6] +-- > z_sro_invert mod12 0 [0,1,3] == [0,11,9] +-- +-- > import Data.Word {- base -} +-- > z_sro_invert mod12 (0::Word8) [1,4,8] +z_sro_invert :: (Integral i, Functor f) => Z i -> i -> f i -> f i +z_sro_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 +-- > z_sro_tni mod5 1 [0,1,3] == [1,0,3] +-- > z_sro_tni mod12 4 [1,5,6] == [3,11,10] +-- > (z_sro_invert mod12 0 . z_sro_tn mod12 4) [1,5,6] == [7,3,2] +z_sro_tni :: (Integral i, Functor f) => Z i -> i -> f i -> f i +z_sro_tni z n = z_sro_tn z n . z_sro_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) +-- > z_sro_mn mod12 11 [0,1,4,9] == z_tni mod12 0 [0,1,4,9] +z_sro_mn :: (Integral i, Functor f) => Z i -> i -> f i -> f i +z_sro_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] +-- > length (z_sro_t_related mod12 [0,3,6,9]) == 12 +-- > z_sro_t_related mod5 [0,2] == [[0,2],[1,3],[2,4],[3,0],[4,1]] +z_sro_t_related :: (Integral i, Functor f) => Z i -> f i -> [f i] +z_sro_t_related z p = fmap (\n -> z_sro_tn z n p) (z_univ z) -- | 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)) +-- > length (z_sro_ti_related mod12 [0,1,3]) == 24 +-- > length (z_sro_ti_related mod12 [0,3,6,9]) == 24 +-- > z_sro_ti_related mod12 [0] == map return [0..11] +z_sro_ti_related :: (Eq (f i), Integral i, Functor f) => Z i -> f i -> [f i] +z_sro_ti_related z p = nub (z_sro_t_related z p ++ z_sro_t_related z (z_sro_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) +-- > length (z_sro_rti_related mod12 [0,1,3]) == 48 +-- > length (z_sro_rti_related mod12 [0,3,6,9]) == 24 +z_sro_rti_related :: Integral i => Z i -> [i] -> [[i]] +z_sro_rti_related z p = let q = z_sro_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 = +-- > z_sro_tn_to mod12 5 [0,1,3] == [5,6,8] +-- > map (z_sro_tn_to mod12 0) [[0,1,3],[1,3,0],[3,0,1]] +z_sro_tn_to :: Integral i => Z i -> i -> [i] -> [i] +z_sro_tn_to z n p = case p of [] -> [] - x:xs -> n : tn z (z_sub z n x) xs + x:xs -> n : z_sro_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 +-- > map (z_sro_invert_ix mod12 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] +-- > map (z_sro_invert_ix mod12 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] +z_sro_invert_ix :: Integral i => Z i -> Int -> [i] -> [i] +z_sro_invert_ix z n p = z_sro_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)) +-- > z_tmatrix mod12 [0,1,3] == [[0,1,3],[11,0,2],[9,10,0]] +z_tmatrix :: Integral i => Z i -> [i] -> [[i]] +z_tmatrix z p = map (\n -> z_sro_tn z n p) (z_sro_tn_to z 0 (z_sro_invert_ix z 0 p)) diff --git a/Music/Theory/Z/TTO.hs b/Music/Theory/Z/TTO.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/TTO.hs @@ -0,0 +1,75 @@ +module Music.Theory.Z.TTO where + +import Data.List {- base -} +import Data.Maybe {- base -} +import qualified Text.ParserCombinators.Parsec as P {- parsec -} + +import qualified Music.Theory.Parse as T +import qualified Music.Theory.Set.List as T +import Music.Theory.Z + +-- | Twelve-tone operator, of the form TMI. +data TTO t = TTO {tto_T :: t,tto_M :: Bool,tto_I :: Bool} + deriving (Eq,Show) + +tto_identity :: Num t => TTO t +tto_identity = TTO 0 False False + +-- | Pretty printer. +tto_pp :: Show t => TTO t -> String +tto_pp (TTO t m i) = concat ['T' : show t,if m then "M" else "",if i then "I" else ""] + +p_tto :: Integral t => P.GenParser Char () (TTO t) +p_tto = do + _ <- P.char 'T' + t <- T.parse_int + m <- T.is_char 'M' + i <- T.is_char 'I' + P.eof + return (TTO t m i) + +-- | Parser, transposition must be decimal. +-- +-- > map (tto_pp . tto_parse) (words "T5 T3I T11M T9MI") +tto_parse :: Integral i => String -> TTO i +tto_parse = either (\e -> error ("tto_parse failed\n" ++ show e)) id . P.parse p_tto "" + +-- | The set of all 'TTO', given 'Z' function. +-- +-- > length (z_tto_univ mod12) == 48 +-- > map tto_pp (z_tto_univ mod12) +z_tto_univ :: Integral t => Z t -> [TTO t] +z_tto_univ z = [TTO t m i | m <- [False,True], i <- [False,True], t <- z_univ z] + +-- | M is ordinarily 5, but can be specified here. +-- +-- > map (z_tto_f 5 mod12 (tto_parse "T1M")) [0,1,2,3] == [1,6,11,4] +z_tto_f :: Integral t => t -> Z t -> TTO t -> (t -> t) +z_tto_f mn z (TTO t m i) = + let i_f = if i then z_negate z else id + m_f = if m then z_mul z mn else id + t_f = if t > 0 then z_add z t else id + in t_f . m_f . i_f + +-- | 'sort' of 'map' 'z_tto_f'. +-- +-- > z_tto_apply 5 mod12 (tto_parse "T1M") [0,1,2,3] == [1,4,6,11] +z_tto_apply :: Integral t => t -> Z t -> TTO t -> [t] -> [t] +z_tto_apply mn z o = sort . map (z_tto_f mn z o) + +tto_apply :: Integral t => t -> TTO t -> [t] -> [t] +tto_apply mn = z_tto_apply mn id + +-- | Find 'TTO' that that map /x/ to /y/ given /m/ and /z/. +-- +-- > map tto_pp (z_tto_rel 5 mod12 [0,1,2,3] [6,4,1,11]) == ["T1M","T4MI"] +z_tto_rel :: (Ord t,Integral t) => t -> Z t -> [t] -> [t] -> [TTO t] +z_tto_rel m z x y = + let q = T.set y + in mapMaybe (\o -> if z_tto_apply m z o x == q then Just o else Nothing) (z_tto_univ z) + +-- | 'nub' of 'sort' of 'map' /z/. +-- +-- > map (z_pcset mod12) [[0,6],[6,12],[12,18]] == replicate 3 [0,6] +z_pcset :: Ord t => Z t -> [t] -> [t] +z_pcset z = nub . sort . map z diff --git a/Music/Theory/Z12.hs b/Music/Theory/Z12.hs --- a/Music/Theory/Z12.hs +++ b/Music/Theory/Z12.hs @@ -1,102 +1,111 @@ -{-# Language GeneralizedNewtypeDeriving #-} -module Music.Theory.Z12 where +{-# Language DataKinds #-} +{- | Z12 -import Data.List {- base -} +Z12 are modulo 12 integers. --- | 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) +> map signum [-1,0::Z12,1] == [1,0,1] +> map abs [-1,0::Z12,1] == [11,0,1] --- | 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 +Aspects of the 'Enum' instance are cyclic. --- | 'Bounded' instance for Z12. --- --- > [minBound::Z12 .. maxBound] == [0::Z12 .. 11] -instance Bounded Z12 where - minBound = Z12 0 - maxBound = Z12 11 +> pred (0::Z12) == 11 +> succ (11::Z12) == 0 --- | 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 +'Bounded' works --- | 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 +> [minBound::Z12 .. maxBound] == [0::Z12 .. 11] -instance Show Z12 where showsPrec = z12_showsPrec +-} +module Music.Theory.Z12 where --- | Lift unary function over integers to Z12. +import Data.Char {- base -} +import Data.List {- base -} +import qualified Data.Modular as M {- modular-arithmetic -} +import qualified GHC.TypeLits as L {- base -} + +import qualified Music.Theory.List as T {- hmt -} + +-- | 'Mod' 'Int'. +type Z n = M.Mod Int n + +-- | 'Z' 12. -- --- > lift_unary_Z12 (negate) 7 == 5 -lift_unary_Z12 :: (Int -> Int) -> Z12 -> Z12 -lift_unary_Z12 f (Z12 a) = Z12 (f a `mod` 12) +-- > map negate [0::Z12 .. 0xB] == [0,0xB,0xA,9,8,7,6,5,4,3,2,1] +-- > map (+ 5) [0::Z12 .. 11] == [5,6,7,8,9,0xA,0xB,0,1,2,3,4] +type Z12 = M.Mod Int 12 --- | Lift unary function over integers to Z12. +-- | Cyclic form of 'enumFromThenTo'. -- --- > 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) +-- > [9::Z12,11 .. 3] == [] +-- > enumFromThenTo_cyc (9::Z12) 11 3 == [9,11,1,3] +enumFromThenTo_cyc :: L.KnownNat n => Z n -> Z n -> Z n -> [Z n] +enumFromThenTo_cyc n m o = + let m' = m + (m - n) + in case compare m' o of + LT -> n : enumFromThenTo_cyc m m' o + EQ -> [n,m,o] + GT -> [n,m] --- | 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) +-- | Cyclic form of 'enumFromTo'. +-- +-- > [9::Z12 .. 3] == [] +-- > enumFromTo_cyc (9::Z12) 3 == [9,10,11,0,1,2,3] +enumFromTo_cyc :: L.KnownNat n => Z n -> Z n -> [Z n] +enumFromTo_cyc n m = + let n' = succ n + in if n' == m then [n,m] else n : enumFromTo_cyc n' m -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 +to_Z12 = M.toMod . fromIntegral +int_to_Z12 :: Int -> Z12 +int_to_Z12 = to_Z12 + -- | Convert 'Z12' to integral. from_Z12 :: Integral i => Z12 -> i -from_Z12 = fromIntegral +from_Z12 = fromIntegral . M.unMod +int_from_Z12 :: Z12 -> Int +int_from_Z12 = from_Z12 + -- | Z12 not in set. -- -- > complement [0,2,4,5,7,9,11] == [1,3,6,8,10] complement :: [Z12] -> [Z12] complement = (\\) [0 .. 11] + +-- | Z12 to character (10 -> A, 11 -> B). +-- +-- > map z12_to_char [0 .. 11] == "0123456789AB" +z12_to_char :: Z12 -> Char +z12_to_char = toUpper . intToDigit . M.unMod + +-- | Z12 to character (10 -> A, 11 -> B). +-- +-- > map char_to_z12 "0123456789AB" == [0..11] +char_to_z12 :: Char -> Z12 +char_to_z12 = to_Z12 . digitToInt + +-- | Unordered set notation (braces). +-- +-- > z12_set_pp [0,1,3] == "{013}" +z12_set_pp :: [Z12] -> String +z12_set_pp = T.bracket ('{','}') . map z12_to_char + +-- | Ordered sequence notation (angle brackets). +-- +-- > z12_seq_pp [0,1,3] == "<013>" +z12_seq_pp :: [Z12] -> String +z12_seq_pp = T.bracket ('<','>') . map z12_to_char + +-- | Ordered vector notation (square brackets). +-- +-- > z12_vec_pp [0,1,3] == "[013]" +z12_vec_pp :: [Z12] -> String +z12_vec_pp = T.bracket ('[',']') . map z12_to_char diff --git a/Music/Theory/Z12/Castren_1994.hs b/Music/Theory/Z12/Castren_1994.hs --- a/Music/Theory/Z12/Castren_1994.hs +++ b/Music/Theory/Z12/Castren_1994.hs @@ -7,17 +7,18 @@ 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 +import Music.Theory.Z (mod12) +import qualified Music.Theory.Z.SRO as T +import qualified Music.Theory.Z.Forte_1973 as T +type Z12 = Int + -- | 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] +-- > map inv_sym (T.scs_n 2) == [True,True,True,True,True,True] +-- > map (fromEnum.inv_sym) (T.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] +inv_sym x = x `elem` map (\i -> sort (T.z_sro_tn mod12 i (T.z_sro_invert mod12 0 x))) [0..11] -- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'. -- @@ -27,7 +28,7 @@ sc_t_ti p = if inv_sym p then Nothing - else Just (p,T.t_prime (T.invert 0 p)) + else Just (p,T.t_prime mod12 (T.z_sro_invert mod12 0 p)) -- | Transpositional equivalence variant of Forte's 'sc_table'. The -- inversionally related classes are distinguished by labels @A@ and @@ -35,11 +36,11 @@ -- 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) +-- > (length T.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 + let f x = let nm = T.sc_name mod12 x in case sc_t_ti x of Nothing -> [(nm,x)] Just (p,q) -> [(nm++"A",p),(nm++"B",q)] @@ -52,7 +53,7 @@ -- > 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 + let n = find (\(_,q) -> T.t_prime mod12 p == q) t_sc_table in fst (fromJust n) -- | Lookup a set-class given a set-class name. @@ -77,7 +78,7 @@ -- > 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_subsets x a = filter (`T.is_subset` x) (map sort (T.z_sro_t_related mod12 a)) -- | T\/I-related /q/ that are subsets of /p/. -- @@ -85,7 +86,7 @@ -- > 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) +ti_subsets x a = filter (`T.is_subset` x) (nub (map sort (T.z_sro_ti_related mod12 a))) -- | Trivial run length encoder. -- @@ -135,7 +136,7 @@ -- > 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 + let p' = T.icv 12 p in map (sum p' *) p' -- | /rel/ metric. diff --git a/Music/Theory/Z12/Drape_1999.hs b/Music/Theory/Z12/Drape_1999.hs --- a/Music/Theory/Z12/Drape_1999.hs +++ b/Music/Theory/Z12/Drape_1999.hs @@ -1,19 +1,26 @@ -- | Haskell implementations of @pct@ operations. --- See . +-- See . module Music.Theory.Z12.Drape_1999 where import Data.Function {- base -} import Data.List {- base -} import Data.Maybe {- base -} +import Safe {- safe -} 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 +import qualified Music.Theory.Tuple as T +import qualified Music.Theory.Z as Z +import qualified Music.Theory.Z.SRO as Z +import qualified Music.Theory.Z.TTO as Z + +import Music.Theory.Z12 (Z12) +import qualified Music.Theory.Z12 as Z12 +import qualified Music.Theory.Z12.Forte_1973 as Z12 +import qualified Music.Theory.Z12.TTO as Z12 +import qualified Music.Theory.Z12.SRO as Z12 + -- | Cardinality filter -- -- > cf [0,3] (cg [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]] @@ -24,6 +31,7 @@ -- values for slot. -- -- > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]] +-- > let n = "01" in cgg [n,n,n] == ["000","001","010","011","100","101","110","111"] cgg :: [[a]] -> [[a]] cgg l = case l of @@ -38,7 +46,7 @@ -- | Powerset filtered by cardinality. -- --- >>> cg -r3 0159 +-- >>> pct cg -r3 0159 -- 015 -- 019 -- 059 @@ -48,22 +56,49 @@ cg_r :: (Integral n) => n -> [a] -> [[a]] cg_r n = cf [n] . cg --- | Cyclic interval segment. +{- | Chain pcsegs. + +>>> echo 024579 | pct chn T0 3 | sort -u +579468 (RT8M) +579A02 (T5) + +> chn_t0 3 [0,2,4,5,7,9] == [[5,7,9,10,0,2],[5,7,9,4,6,8]] + +>>> echo 02457t | pct chn T0 2 +7A0135 (RT5I) +7A81B9 (RT9MI) + +> chn_t0 2 [0,2,4,5,7,10] == [[7,10,0,1,3,5],[7,10,8,1,11,9]] + +-} +chn_t0 :: Int -> [Z12] -> [[Z12]] +chn_t0 n p = + let f q = T.take_right n p == take n q + in filter f (Z12.sro_rtmi_related p) + +{- | Cyclic interval segment. + +>>> echo 014295e38t76 | pct cisg +13A7864529B6 + +> ciseg [0,1,4,2,9,5,11,3,8,10,7,6] == [1,3,10,7,8,6,4,5,2,9,11,6] + +-} ciseg :: [Z12] -> [Z12] -ciseg = T.int . cyc +ciseg = T.d_dx . cyc -- | Synonynm for 'complement'. -- --- >>> cmpl 02468t +-- >>> pct cmpl 02468t -- 13579B -- -- > cmpl [0,2,4,6,8,10] == [1,3,5,7,9,11] cmpl :: [Z12] -> [Z12] -cmpl = complement +cmpl = Z12.complement -- | Form cycle. -- --- >>> cyc 056 +-- >>> echo 056 | pct cyc -- 0560 -- -- > cyc [0,5,6] == [0,5,6,0] @@ -86,7 +121,7 @@ -- | Diatonic implications. dim :: [Z12] -> [(Z12,[Z12])] dim p = - let g (i,q) = T.is_subset p (TTO.tn i q) + let g (i,q) = T.is_subset p (Z12.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] @@ -95,7 +130,7 @@ -- | Variant of 'dim' that is closer to the 'pct' form. -- --- >>> dim 016 +-- >>> pct dim 016 -- T1d -- T1m -- T0o @@ -110,7 +145,7 @@ -- | Diatonic interval set to interval set. -- --- >>> dis 24 +-- >>> pct dis 24 -- 1256 -- -- > dis [2,4] == [1,2,5,6] @@ -121,59 +156,106 @@ -- | Degree of intersection. -- --- >>> echo 024579e | doi 6 | sort -u +-- >>> echo 024579e | pct 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 +-- >>> echo 01234 | pct 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] + let f j = [Z12.tto_tn j p,Z12.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 +fn = Z12.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) +-- | Z12 cycles. +frg_cyc :: T.T6 [[Z12]] +frg_cyc = + let c1 = [[0..11]] + c2 = map (\n -> map (+ n) [0,2..10]) [0..1] + c3 = map (\n -> map (+ n) [0,3..9]) [0..2] + c4 = map (\n -> map (+ n) [0,4..8]) [0..3] + c5 = map (map (* 5)) c1 + c6 = map (\n -> map (+ n) [0,6]) [0..5] + in (c1,c2,c3,c4,c5,c6) +-- | Fragmentation of cycles. +frg :: [Z12] -> T.T6 [String] +frg p = + let f = map (\n -> if n `elem` p then Z12.z12_to_char n else '-') + in T.t6_map (map f) frg_cyc + +ic_cycle_vector :: [Z12] -> T.T6 [Int] +ic_cycle_vector p = + let f str = let str' = if length str > 2 then T.close str else str + in length (filter (\(x,y) -> x /= '-' && y /= '-') (T.adj2 1 str')) + in T.t6_map (map f) (frg p) + +-- | Pretty printer for 'ic_cycle_vector'. +-- +-- > let r = "IC cycle vector: <1> <22> <111> <1100> <5> <000000>" +-- > in ic_cycle_vector_pp (ic_cycle_vector [0,2,4,5,7,9]) == r +ic_cycle_vector_pp :: T.T6 [Int] -> String +ic_cycle_vector_pp = ("IC cycle vector: " ++) . unwords . T.t6_to_list . T.t6_map Z.z16_seq_pp + +frg_hdr :: [String] +frg_hdr = map (\n -> "Fragmentation of " ++ show n ++ "-cycle(s)") [1::Int .. 6] + +{-| Fragmentation of cycles. + +>>> pct frg 024579 +Fragmentation of 1-cycle(s): [0-2-45-7-9--] +Fragmentation of 2-cycle(s): [024---] [--579-] +Fragmentation of 3-cycle(s): [0--9] [-47-] [25--] +Fragmentation of 4-cycle(s): [04-] [-59] [2--] [-7-] +Fragmentation of 5-cycle(s): [05------4927] +Fragmentation of 6-cycle(s): [0-] [-7] [2-] [-9] [4-] [5-] +IC cycle vector: <1> <22> <111> <1100> <5> <000000> + +> putStrLn $ frg_pp [0,2,4,5,7,9] +-} +frg_pp :: [Z12] -> String +frg_pp = + let f = unwords . map (\p -> T.bracket ('[',']') p) + g x y = x ++ ": " ++ y + in unlines . zipWith g frg_hdr . T.t6_to_list . T.t6_map f . frg + -- | Embedded segment search. -- --- >>> echo 23a | ess 0164325 +-- >>> echo 23A | pct 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 [0,1,6,4,3,2,5] [2,3,10] == [[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 +ess p q = filter (`T.is_embedding` q) (Z12.sro_rtmi_related p) -- | 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)) + in pf q `elem` map pf (cf [n] (cg p)) -- | Can the set-class q be drawn from the pcset p. +-- +-- > let d = [0,2,4,5,7,9,11] in has_sc d (complement d) == True +-- > has_sc [] [] == True has_sc :: [Z12] -> [Z12] -> Bool -has_sc = has_sc_pf T.forte_prime +has_sc = has_sc_pf Z12.forte_prime -- | Interval cycle filter. -- --- >>> echo 22341 | icf +-- >>> echo 22341 | pct icf -- 22341 -- -- > icf [[2,2,3,4,1]] == [[2,2,3,4,1]] @@ -182,7 +264,7 @@ -- | Interval class set to interval sets. -- --- >>> ici -c 123 +-- >>> pct ici -c 123 -- 123 -- 129 -- 1A3 @@ -204,51 +286,57 @@ -- | Interval-class segment. -- --- >>> icseg 013265e497t8 +-- >>> pct 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 +icseg = map Z12.ic . iseg -- | Interval segment (INT). iseg :: [Z12] -> [Z12] -iseg = T.int +iseg = T.d_dx -- | Imbrications. -imb :: (Integral n) => [n] -> [a] -> [[a]] +-- +-- > let r = [[[0,2,4],[2,4,5],[4,5,7],[5,7,9]] +-- > ,[[0,2,4,5],[2,4,5,7],[4,5,7,9]]] +-- > in imb [3,4] [0,2,4,5,7,9] == r +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 + in map (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' gives the set-classes that can append to 'p' to give 'q'. + +>>> pct 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)) + f = any id . map (\x -> Z12.forte_prime (p ++ x) == q) . Z12.tto_ti_related + in map Z12.sc_name (filter f (cf [k] Z12.scs)) -- | Matrix search. -- --- >>> mxs 024579 642 | sort -u +-- >>> pct 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) +mxs p q = filter (q `isInfixOf`) (Z12.sro_rti_related p) -- | Normalize. -- --- >>> nrm 0123456543210 +-- >>> pct nrm 0123456543210 -- 0123456 -- -- > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6] @@ -259,84 +347,242 @@ 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) +{- | Pitch-class invariances (called @pi@ at @pct@). --- | Relate sets. +>>> pct pi 0236 12 +pcseg 0236 +pcseg 6320 +pcseg 532B +pcseg B235 + +> pci [1,2] [0,2,3,6] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]] + +-} +pci :: [Int] -> [Z12] -> [[Z12]] +pci i p = + let f q = T.set (map (q !!) i) + in filter (\q -> f q == f p) (Z12.sro_rti_related p) + +-- | Relate sets (TnMI). -- --- >>> rs 0123 641e +-- >>> pct 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 [0,1,2,3] [6,4,1,11] == [(Z.tto_parse "T1M",[1,6,11,4]) +-- > ,(Z.tto_parse "T4MI",[4,11,6,1])] +rs :: [Z12] -> [Z12] -> [(Z.TTO Z12, [Z12])] rs x y = - let xs = map (\o -> (o, o `T.sro` x)) T.sro_TnMI + let xs = map (\o -> (o,Z.z_tto_apply 5 id o x)) (Z.z_tto_univ id) 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)) +rs1 :: [Z12] -> [Z12] -> Maybe (Z.TTO Z12) +rs1 p = fmap fst . headMay . rs p +{- | Relate segments. + +>>> pct rsg 156 3BA +T4I + +> rsg [1,5,6] [3,11,10] == [Z.sro_parse "T4I",Z.sro_parse "r1RT4MI"] + +>>> pct rsg 0123 05t3 +T0M + +> rsg [0,1,2,3] [0,5,10,3] == [Z.sro_parse "T0M",Z.sro_parse "RT3MI"] + +>>> pct rsg 0123 4e61 +RT1M + +> rsg [0,1,2,3] [4,11,6,1] == [Z.sro_parse "T4MI",Z.sro_parse "RT1M"] + +>>> echo e614 | pct rsg 0123 +r3RT1M + +> rsg [0,1,2,3] [11,6,1,4] == [Z.sro_parse "r1T4MI",Z.sro_parse "r1RT1M"] + +-} +rsg :: [Z12] -> [Z12] -> [Z.SRO Z12] +rsg x y = filter (\o -> sro o x == y) (Z.z_sro_univ (length x) id) + -- | Subsets. sb :: [[Z12]] -> [[Z12]] sb xs = let f p = all id (map (`has_sc` p) xs) - in filter f T.scs + in filter f Z12.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] +{- | scc = set class completion + +>>> pct scc 6-32 168 +35A +49B +3AB +34B + +> scc (Z12.sc "6-32") [1,6,8] == [[3,5,10],[4,9,11],[3,10,11],[3,4,11]] + +-} +scc :: [Z12] -> [Z12] -> [[Z12]] +scc r p = map (\\ p) (filter (T.is_subset p) (Z12.tto_ti_related r)) + +si_hdr :: [String] +si_hdr = + ["pitch-class-set" + ,"set-class" + ,"interval-class-vector" + ,"tics" + ,"complement" + ,"multiplication-by-five-transform"] + +type SI = ([Z12],Z.TTO Z12,[Z12]) + +-- > si_raw [0,5,3,11] +si_raw :: [Z12] -> (SI,[Z12],[Int],SI,SI) +si_raw p = + let n = length p + p_icv = Z12.to_Z12 n : Z12.icv p + gen_si x = let x_f = Z12.forte_prime x + Just x_o = rs1 x_f x + in (nub (sort x),x_o,x_f) + in (gen_si p,p_icv,tics p,gen_si (Z12.complement p),gen_si (map (* 5) p)) + +si_raw_pp :: [Z12] -> [String] +si_raw_pp p = + let pf_pp concise (x_o,x_f) = + concat [Z.tto_pp x_o," ",Z12.sc_name x_f + ,if concise then "" else Z12.z12_vec_pp x_f] + si_pp (x,x_o,x_f) = concat [Z12.z12_set_pp x," (",pf_pp True (x_o,x_f),")"] + ((p',p_o,p_f),p_icv,p_tics,c,m) = si_raw p + in [Z12.z12_set_pp p' + ,pf_pp False (p_o,p_f) + ,Z12.z12_vec_pp p_icv + ,Z.z16_vec_pp p_tics + ,si_pp c + ,si_pp m] + +-- | Set information. -- --- > spsc (cf [3] T.scs) == ["6-Z17"] -spsc :: [[Z12]] -> [String] +-- > putStr $ unlines $ si [0,5,3,11] +si :: [Z12] -> [String] +si p = zipWith (\k v -> concat [k,": ",v]) si_hdr (si_raw_pp p) + +{- | Super set-class. + +>>> pct spsc 4-11 4-12 +5-26[02458] + +> spsc [Z12.sc "4-11",Z12.sc "4-12"] == [[0,2,4,5,8]] + +>>> pct spsc 3-11 3-8 +4-27[0258] +4-Z29[0137] + +> spsc [Z12.sc "3-11",Z12.sc "3-8"] == [[0,2,5,8],[0,1,3,7]] + +>>> pct spsc `pct fl 3` +6-Z17[012478] + +> spsc (cf [3] Z12.scs) == [[0,1,2,4,7,8]] + +-} +spsc :: [[Z12]] -> [[Z12]] 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 + in (head . groupBy g . filter f) Z12.scs + +{- | sra = stravinsky rotational array + +>>> echo 019BA7 | pct sra +019BA7 +08A96B +021A34 +0B812A +0923B1 +056243 + +> let r = [[0,1,9,11,10,7],[0,8,10,9,6,11],[0,2,1,10,3,4] +> ,[0,11,8,1,2,10],[0,9,2,3,11,1],[0,5,6,2,4,3]] +> in sra [0,1,9,11,10,7] == r + +-} +sra :: [Z12] -> [[Z12]] +sra = map (Z12.sro_tn_to 0) . T.rotations + +{- | Serial operation. + +>>> echo 156 | pct sro T4 +59A + +> sro (Z.sro_parse "T4") [1,5,6] == [5,9,10] + +>>> echo 024579 | pct sro RT4I +79B024 + +> sro (Z.SRO 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4] + +>>> echo 156 | pct sro T4I +3BA + +> sro (Z.sro_parse "T4I") [1,5,6] == [3,11,10] +> sro (Z.SRO 0 False 4 False True) [1,5,6] == [3,11,10] + +>>> echo 156 | pct sro T4 | pct sro T0I +732 + +> (sro (Z.sro_parse "T0I") . sro (Z.sro_parse "T4")) [1,5,6] == [7,3,2] + +>>> echo 024579 | pct sro RT4I +79B024 + +> sro (Z.sro_parse "RT4I") [0,2,4,5,7,9] == [7,9,11,0,2,4] + +-} +sro :: Z.SRO Z12 -> [Z12] -> [Z12] +sro o = Z.z_sro_apply 5 id o + +-- | Vector indicating degree of intersection with inversion at each transposition. +-- +-- > tics [0,2,4,5,7,9] == [3,2,5,0,5,2,3,4,1,6,1,4] +-- > map tics Z12.scs +tics :: [Z12] -> [Int] +tics p = + let q = Z12.tto_t_related (Z12.tto_invert 0 p) + in map (length . intersect p) q + +{- | tmatrix + +>>> pct tmatrix 1258 + +1258 +0147 +9A14 +67A1 + +> tmatrix [1,2,5,8] == [[1,2,5,8],[0,1,4,7],[9,10,1,4],[6,7,10,1]] + +-} +tmatrix :: [Z12] -> [[Z12]] +tmatrix p = + let i = map negate (T.d_dx p) + in map (\n -> map (+ n) p) (T.dx_d 0 i) + + +{- | trs = transformations search. Search all RTnMI of /p/ for /q/. + +>>> echo 642 | pct trs 024579 | sort -u +531642 +6421B9 +642753 +B97642 + +> let r = [[5,3,1,6,4,2],[6,4,2,1,11,9],[6,4,2,7,5,3],[11,9,7,6,4,2]] +> in sort (trs [0,2,4,5,7,9] [6,4,2]) == r + +-} +trs :: [Z12] -> [Z12] -> [[Z12]] +trs p q = filter (q `isInfixOf`) (Z12.sro_rtmi_related p) + +-- > trs_m [0,2,4,5,7,9] [6,4,2] == [[6,4,2,1,11,9],[11,9,7,6,4,2]] +trs_m :: [Z12] -> [Z12] -> [[Z12]] +trs_m p q = filter (q `isInfixOf`) (Z12.sro_rti_related p) diff --git a/Music/Theory/Z12/Forte_1973.hs b/Music/Theory/Z12/Forte_1973.hs --- a/Music/Theory/Z12/Forte_1973.hs +++ b/Music/Theory/Z12/Forte_1973.hs @@ -2,9 +2,6 @@ -- 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 @@ -14,262 +11,38 @@ -- -- > 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_rotations = Z.t_rotations id -- | 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 +ti_rotations = Z.ti_rotations id -- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'. -- -- > forte_prime [0,1,3,6,8,9] == [0,1,3,6,8,9] +-- > forte_prime [0,2,3,6,7] == [0,1,4,5,7] forte_prime :: [Z12] -> [Z12] -forte_prime = Z.forte_prime z12_modulo +forte_prime = Z.forte_prime id -- | 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 +t_prime = Z.t_prime id -- * Set Class Table --- | Synonym for 'String'. -type SC_Name = String +type SC_Name = Z.SC_Name -- | 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])] +sc_table = Z.sc_table -- | Lookup a set-class name. The input set is subject to -- 'forte_prime' before lookup. @@ -277,15 +50,17 @@ -- > 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) +sc_name = Z.sc_name id +-- > sc_name_long [0,1,4,6,7,8] == "6-Z17[012478]" +sc_name_long :: [Z12] -> SC_Name +sc_name_long = Z.sc_name_long id + -- | 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)) +sc = Z.sc {- | List of set classes (the set class universe). @@ -517,26 +292,26 @@ -} scs :: [[Z12]] -scs = map snd sc_table +scs = Z.scs -- | 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 +scs_n = Z.scs_n -- * BIP Metric -- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\" -- /JMT/ 17/2 (1973):234-272 -- --- >>> bip 0t95728e3416 +-- >>> pct 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 +bip = map int_to_Z12 . Z.bip 12 . map int_from_Z12 -- * ICV Metric @@ -545,10 +320,22 @@ -- > 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 +ic = int_to_Z12 . Z.ic 12 . int_from_Z12 -- | 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 +icv = map fromInteger . Z.icv 12 . map int_from_Z12 + +-- | Type specialise... +icv' :: [Z12] -> [Int] +icv' = icv + +-- * Z-relation + +-- | Locate /Z/ relation of set class. +-- +-- > fmap sc_name (z_relation_of (sc "7-Z12")) == Just "7-Z36" +z_relation_of :: [Z12] -> Maybe [Z12] +z_relation_of = fmap (map int_to_Z12) . Z.z_relation_of 12 . map int_from_Z12 diff --git a/Music/Theory/Z12/Lewin_1980.hs b/Music/Theory/Z12/Lewin_1980.hs --- a/Music/Theory/Z12/Lewin_1980.hs +++ b/Music/Theory/Z12/Lewin_1980.hs @@ -3,8 +3,9 @@ module Music.Theory.Z12.Lewin_1980 where import Data.List -import Music.Theory.Z12 import qualified Music.Theory.Z12.Castren_1994 as C + +type Z12 = Int -- | REL function with given /ncv/ function (see 't_rel' and 'ti_rel'). rel :: Floating n => (Int -> [a] -> [n]) -> [a] -> [a] -> n diff --git a/Music/Theory/Z12/Morris_1974.hs b/Music/Theory/Z12/Morris_1974.hs --- a/Music/Theory/Z12/Morris_1974.hs +++ b/Music/Theory/Z12/Morris_1974.hs @@ -2,35 +2,35 @@ -- /Journal of Music Theory/, 18:364-389, 1974. module Music.Theory.Z12.Morris_1974 where -import Control.Monad.Logic {- logict -} +import qualified Control.Monad.Logic as L {- logict -} --- | 'msum' '.' 'map' 'return'. +-- | 'L.msum' '.' 'map' 'return'. -- --- > observeAll (fromList [1..7]) == [1..7] -fromList :: MonadPlus m => [a] -> m a -fromList = msum . map return +-- > L.observeAll (fromList [1..7]) == [1..7] +fromList :: L.MonadPlus m => [a] -> m a +fromList = L.msum . map return --- | 'MonadPlus' all-interval series. +-- | 'L.MonadLogic' 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] +-- > map (length . L.observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288] +-- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` L.observeAll (all_interval_m 12) +-- > length (L.observeAll (all_interval_m 12)) == 3856 +all_interval_m :: L.MonadLogic m => Int -> m [Int] all_interval_m n = - let rec p q = - if length p == n + let recur k p q = -- k = length p + if k == n then return (reverse p) else do i <- fromList [1 .. n - 1] - guard (i `notElem` p) + L.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] [] + L.guard (m `notElem` q) + recur (k + 1) (i : p) (m : q) + in recur 1 [0] [] --- | 'observeAll' of 'all_interval_m'. +-- | 'L.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 +all_interval = L.observeAll . all_interval_m diff --git a/Music/Theory/Z12/Morris_1987.hs b/Music/Theory/Z12/Morris_1987.hs --- a/Music/Theory/Z12/Morris_1987.hs +++ b/Music/Theory/Z12/Morris_1987.hs @@ -2,98 +2,11 @@ -- 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]] diff --git a/Music/Theory/Z12/Morris_1987/Parse.hs b/Music/Theory/Z12/Morris_1987/Parse.hs --- a/Music/Theory/Z12/Morris_1987/Parse.hs +++ b/Music/Theory/Z12/Morris_1987/Parse.hs @@ -1,45 +1,9 @@ -- | Parsers for pitch class sets and sequences, and for 'SRO's. -module Music.Theory.Z12.Morris_1987.Parse (rnrtnmi,pco) where +module Music.Theory.Z12.Morris_1987.Parse 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 diff --git a/Music/Theory/Z12/Rahn_1980.hs b/Music/Theory/Z12/Rahn_1980.hs --- a/Music/Theory/Z12/Rahn_1980.hs +++ b/Music/Theory/Z12/Rahn_1980.hs @@ -22,4 +22,4 @@ -- > ,[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 +rahn_prime = Z.ti_cmp_prime id rahn_cmp diff --git a/Music/Theory/Z12/Read_1978.hs b/Music/Theory/Z12/Read_1978.hs --- a/Music/Theory/Z12/Read_1978.hs +++ b/Music/Theory/Z12/Read_1978.hs @@ -25,4 +25,4 @@ -- > 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 +encode_prime = Z.encode_prime id diff --git a/Music/Theory/Z12/SRO.hs b/Music/Theory/Z12/SRO.hs --- a/Music/Theory/Z12/SRO.hs +++ b/Music/Theory/Z12/SRO.hs @@ -1,91 +1,92 @@ -- | Serial (ordered) pitch-class operations on 'Z12'. module Music.Theory.Z12.SRO where -import Data.List +import Data.List {- base -} + import qualified Music.Theory.List as T import qualified Music.Theory.Z.SRO as Z -import Music.Theory.Z12 +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 +-- > sro_tn 4 [1,5,6] == [5,9,10] +sro_tn :: Z12 -> [Z12] -> [Z12] +sro_tn = Z.z_sro_tn id -- | 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 +-- > sro_invert 6 [4,5,6] == [8,7,6] +-- > sro_invert 0 [0,1,3] == [0,11,9] +sro_invert :: Z12 -> [Z12] -> [Z12] +sro_invert = Z.z_sro_invert id -- | 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 +-- > (sro_invert 0 . sro_tn 4) [1,5,6] == [7,3,2] +sro_tni :: Z12 -> [Z12] -> [Z12] +sro_tni = Z.z_sro_tni id -- | Modulo 12 multiplication -- --- > mn 11 [0,1,4,9] == tni 0 [0,1,4,9] -mn :: Z12 -> [Z12] -> [Z12] -mn = Z.mn z12_modulo +-- > sro_mn 11 [0,1,4,9] == sro_tni 0 [0,1,4,9] +sro_mn :: Z12 -> [Z12] -> [Z12] +sro_mn = Z.z_sro_mn id -- | M5, ie. 'mn' @5@. -- --- > m5 [0,1,3] == [0,5,3] -m5 :: [Z12] -> [Z12] -m5 = mn 5 +-- > sro_m5 [0,1,3] == [0,5,3] +sro_m5 :: [Z12] -> [Z12] +sro_m5 = sro_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 +-- > length (sro_t_related [0,3,6,9]) == 12 +sro_t_related :: [Z12] -> [[Z12]] +sro_t_related = Z.z_sro_t_related id -- | 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 +sro_ti_related :: [Z12] -> [[Z12]] +sro_ti_related = Z.z_sro_ti_related id -- | 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 +sro_rti_related :: [Z12] -> [[Z12]] +sro_rti_related = Z.z_sro_rti_related id --- | 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) +-- | T\/M\/I-related sequences of /p/, duplicates removed. +sro_tmi_related :: [Z12] -> [[Z12]] +sro_tmi_related p = let q = sro_ti_related p in nub (q ++ map sro_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\/T\/M\/I-related sequences of /p/, duplicates removed. +sro_rtmi_related :: [Z12] -> [[Z12]] +sro_rtmi_related p = let q = sro_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)) +-- | r\/R\/T\/M\/I-related sequences of /p/, duplicates removed. +sro_rrtmi_related :: [Z12] -> [[Z12]] +sro_rrtmi_related p = nub (concatMap sro_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 +-- > sro_tn_to 5 [0,1,3] == [5,6,8] +-- > map (sro_tn_to 0) [[0,1,3],[1,3,0],[3,0,1]] == [[0,1,3],[0,2,11],[0,9,10]] +sro_tn_to :: Z12 -> [Z12] -> [Z12] +sro_tn_to = Z.z_sro_tn_to id -- | 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 +-- > map (sro_invert_ix 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] +-- > map (sro_invert_ix 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] +sro_invert_ix :: Int -> [Z12] -> [Z12] +sro_invert_ix = Z.z_sro_invert_ix id -- | The standard t-matrix of /p/. -- @@ -93,4 +94,4 @@ -- > ,[11,0,2] -- > ,[9,10,0]] tmatrix :: [Z12] -> [[Z12]] -tmatrix = Z.tmatrix z12_modulo +tmatrix = Z.z_tmatrix id diff --git a/Music/Theory/Z12/TTO.hs b/Music/Theory/Z12/TTO.hs --- a/Music/Theory/Z12/TTO.hs +++ b/Music/Theory/Z12/TTO.hs @@ -1,7 +1,8 @@ -- | Pitch-class set (unordered) operations on 'Z12'. module Music.Theory.Z12.TTO where -import Data.List +import Data.List {- base -} + import Music.Theory.Z12 -- | Map to pitch-class and reduce to set. @@ -12,47 +13,47 @@ -- | 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) +-- > tto_tn 4 [1,5,6] == [5,9,10] +-- > tto_tn 4 [0,4,8] == [0,4,8] +tto_tn :: Z12 -> [Z12] -> [Z12] +tto_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)) +-- > tto_invert 6 [4,5,6] == [6,7,8] +-- > tto_invert 0 [0,1,3] == [0,9,11] +tto_invert :: Z12 -> [Z12] -> [Z12] +tto_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 +-- > tto_tni 4 [1,5,6] == [3,10,11] +-- > (tto_invert 0 . tto_tn 4) [1,5,6] == [2,3,7] +tto_tni :: Z12 -> [Z12] -> [Z12] +tto_tni n = tto_tn n . tto_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) +-- > tto_mn 11 [0,1,4,9] == tto_invert 0 [0,1,4,9] +tto_mn :: Z12 -> [Z12] -> [Z12] +tto_mn n = sort . map (* n) -- | M5, ie. 'mn' @5@. -- --- > m5 [0,1,3] == [0,3,5] -m5 :: [Z12] -> [Z12] -m5 = mn 5 +-- > tto_m5 [0,1,3] == [0,3,5] +tto_m5 :: [Z12] -> [Z12] +tto_m5 = tto_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]) +-- > length (tto_t_related [0,1,3]) == 12 +-- > tto_t_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]] +tto_t_related :: [Z12] -> [[Z12]] +tto_t_related p = nub (map (`tto_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)) +-- > length (tto_ti_related [0,1,3]) == 24 +-- > tto_ti_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]] +tto_ti_related :: [Z12] -> [[Z12]] +tto_ti_related p = nub (tto_t_related p ++ tto_t_related (tto_invert 0 p)) diff --git a/README b/README --- a/README +++ b/README @@ -6,10 +6,16 @@ - [hmt-diagrams][hmt-diagrams] +## cli + +[db](?t=hmt&e=md/db.md), +[pct](?t=hmt&e=md/pct.md), +[scala](?t=hmt&e=md/scala.md) + [hs]: http://haskell.org/ [hmt-diagrams]: http://rd.slavepianos.org/?t=hmt-diagrams -© [rohan drape][rd], 2006-2014, [gpl][gpl]. +© [rohan drape][rd], 2006-2017, [gpl][gpl]. [rd]: http://rd.slavepianos.org/ [gpl]: http://gnu.org/copyleft/ diff --git a/data/csv/mnd/1080-C01.csv b/data/csv/mnd/1080-C01.csv new file mode 100644 --- /dev/null +++ b/data/csv/mnd/1080-C01.csv @@ -0,0 +1,1801 @@ +time,on/off,note,velocity,channel,param +0.0000,on,62,100,1, +1.0000,off,62,0,1, +1.0000,on,69,100,1, +2.0000,off,69,0,1, +2.0000,on,65,100,1, +3.0000,off,65,0,1, +3.0000,on,62,100,1, +4.0000,off,62,0,1, +4.0000,on,61,100,1, +5.0000,off,61,0,1, +5.0000,on,62,100,1, +5.5000,off,62,0,1, +5.5000,on,64,100,1, +6.0000,off,64,0,1, +6.0000,on,65,100,1, +7.2500,off,65,0,1, +7.2500,on,67,100,1, +7.5000,off,67,0,1, +7.5000,on,65,100,1, +7.7500,off,65,0,1, +7.7500,on,64,100,1, +8.0000,off,64,0,1, +8.0000,on,69,100,0, +8.0000,on,62,100,1, +8.5000,off,62,0,1, +8.5000,on,64,100,1, +9.0000,off,69,0,0, +9.0000,off,64,0,1, +9.0000,on,74,100,0, +9.0000,on,65,100,1, +9.5000,off,65,0,1, +9.5000,on,67,100,1, +10.0000,off,74,0,0, +10.0000,off,67,0,1, +10.0000,on,72,100,0, +10.0000,on,69,100,1, +10.5000,off,69,0,1, +10.5000,on,57,100,1, +10.7500,off,57,0,1, +10.7500,on,59,100,1, +11.0000,off,72,0,0, +11.0000,off,59,0,1, +11.0000,on,69,100,0, +11.0000,on,60,100,1, +11.2500,off,60,0,1, +11.2500,on,57,100,1, +11.5000,off,57,0,1, +11.5000,on,65,100,1, +12.0000,off,69,0,0, +12.0000,on,68,100,0, +12.2500,off,65,0,1, +12.2500,on,59,100,1, +12.5000,off,59,0,1, +12.5000,on,64,100,1, +13.0000,off,68,0,0, +13.0000,on,69,100,0, +13.2500,off,64,0,1, +13.2500,on,65,100,1, +13.5000,off,69,0,0, +13.5000,off,65,0,1, +13.5000,on,71,100,0, +13.5000,on,64,100,1, +13.7500,off,64,0,1, +13.7500,on,62,100,1, +14.0000,off,71,0,0, +14.0000,off,62,0,1, +14.0000,on,72,100,0, +14.0000,on,64,100,1, +14.5000,off,64,0,1, +14.5000,on,66,100,1, +15.0000,off,66,0,1, +15.0000,on,67,100,1, +15.2500,off,72,0,0, +15.2500,on,74,100,0, +15.5000,off,74,0,0, +15.5000,on,72,100,0, +15.7500,off,72,0,0, +15.7500,on,70,100,0, +16.0000,off,70,0,0, +16.0000,on,69,100,0, +16.0000,on,50,100,3, +16.2500,off,69,0,0, +16.2500,on,62,100,0, +16.5000,off,67,0,1, +16.5000,off,62,0,0, +16.5000,on,74,100,0, +16.5000,on,65,100,1, +17.0000,off,50,0,3, +17.0000,off,65,0,1, +17.0000,on,64,100,1, +17.0000,on,57,100,3, +17.5000,off,74,0,0, +17.5000,on,73,100,0, +18.0000,off,64,0,1, +18.0000,off,57,0,3, +18.0000,off,73,0,0, +18.0000,on,74,100,0, +18.0000,on,62,100,1, +18.0000,on,53,100,3, +18.2500,off,74,0,0, +18.2500,on,69,100,0, +18.5000,off,69,0,0, +18.5000,on,72,100,0, +18.7500,off,62,0,1, +18.7500,on,64,100,1, +19.0000,off,53,0,3, +19.0000,off,64,0,1, +19.0000,on,65,100,1, +19.0000,on,50,100,3, +19.2500,off,72,0,0, +19.2500,on,69,100,0, +19.5000,off,69,0,0, +19.5000,on,70,100,0, +19.7500,off,65,0,1, +19.7500,on,62,100,1, +20.0000,off,50,0,3, +20.0000,off,62,0,1, +20.0000,on,67,100,1, +20.0000,on,49,100,3, +20.2500,off,70,0,0, +20.2500,on,64,100,0, +20.5000,off,64,0,0, +20.5000,on,69,100,0, +20.7500,off,67,0,1, +20.7500,on,67,100,1, +21.0000,off,49,0,3, +21.0000,off,67,0,1, +21.0000,on,65,100,1, +21.0000,on,50,100,3, +21.2500,off,65,0,1, +21.2500,on,64,100,1, +21.5000,off,50,0,3, +21.5000,off,64,0,1, +21.5000,on,62,100,1, +21.5000,on,52,100,3, +21.7500,off,62,0,1, +21.7500,on,61,100,1, +22.0000,off,69,0,0, +22.0000,off,52,0,3, +22.0000,off,61,0,1, +22.0000,on,69,100,0, +22.0000,on,62,100,1, +22.0000,on,53,100,3, +22.2500,off,69,0,0, +22.2500,on,72,100,0, +22.5000,off,62,0,1, +22.5000,on,67,100,1, +22.7500,off,72,0,0, +22.7500,on,71,100,0, +23.0000,off,71,0,0, +23.0000,on,72,100,0, +23.2500,off,53,0,3, +23.2500,on,55,100,3, +23.5000,off,67,0,1, +23.5000,off,55,0,3, +23.5000,on,60,100,1, +23.5000,on,53,100,3, +23.7500,off,53,0,3, +23.7500,on,52,100,3, +24.0000,off,60,0,1, +24.0000,off,52,0,3, +24.0000,on,65,100,1, +24.0000,on,57,100,2, +24.0000,on,50,100,3, +24.2500,off,72,0,0, +24.2500,on,62,100,0, +24.5000,off,62,0,0, +24.5000,on,72,100,0, +24.7500,off,65,0,1, +24.7500,on,64,100,1, +25.0000,off,57,0,2, +25.0000,off,50,0,3, +25.0000,off,64,0,1, +25.0000,on,65,100,1, +25.0000,on,62,100,2, +25.2500,off,72,0,0, +25.2500,on,69,100,0, +25.5000,off,69,0,0, +25.5000,on,71,100,0, +25.7500,off,65,0,1, +25.7500,on,56,100,1, +26.0000,off,62,0,2, +26.0000,off,56,0,1, +26.0000,on,64,100,1, +26.0000,on,60,100,2, +26.5000,off,71,0,0, +26.5000,on,69,100,0, +26.5000,on,45,100,3, +26.7500,off,69,0,0, +26.7500,off,45,0,3, +26.7500,on,68,100,0, +26.7500,on,47,100,3, +27.0000,off,60,0,2, +27.0000,off,68,0,0, +27.0000,off,47,0,3, +27.0000,on,69,100,0, +27.0000,on,57,100,2, +27.0000,on,48,100,3, +27.2500,off,48,0,3, +27.2500,on,45,100,3, +27.5000,off,64,0,1, +27.5000,off,45,0,3, +27.5000,on,62,100,1, +27.5000,on,53,100,3, +27.7500,off,62,0,1, +27.7500,on,60,100,1, +28.0000,off,69,0,0, +28.0000,off,57,0,2, +28.0000,off,60,0,1, +28.0000,on,71,100,0, +28.0000,on,62,100,1, +28.0000,on,56,100,2, +28.2500,off,53,0,3, +28.2500,off,62,0,1, +28.2500,on,65,100,1, +28.2500,on,47,100,3, +28.5000,off,65,0,1, +28.5000,off,47,0,3, +28.5000,on,64,100,1, +28.5000,on,52,100,3, +28.7500,off,64,0,1, +28.7500,on,62,100,1, +29.0000,off,71,0,0, +29.0000,off,56,0,2, +29.0000,off,62,0,1, +29.0000,on,72,100,0, +29.0000,on,60,100,1, +29.0000,on,57,100,2, +29.2500,off,52,0,3, +29.2500,on,53,100,3, +29.5000,off,72,0,0, +29.5000,off,60,0,1, +29.5000,off,57,0,2, +29.5000,off,53,0,3, +29.5000,on,74,100,0, +29.5000,on,59,100,2, +29.5000,on,52,100,3, +29.7500,off,52,0,3, +29.7500,on,50,100,3, +30.0000,off,74,0,0, +30.0000,off,59,0,2, +30.0000,off,50,0,3, +30.0000,on,67,100,0, +30.0000,on,60,100,2, +30.0000,on,52,100,3, +30.2500,off,67,0,0, +30.2500,off,52,0,3, +30.2500,on,70,100,0, +30.2500,on,55,100,3, +30.5000,off,70,0,0, +30.5000,off,55,0,3, +30.5000,on,69,100,0, +30.5000,on,54,100,3, +30.7500,off,54,0,3, +30.7500,on,57,100,3, +31.0000,off,57,0,3, +31.0000,on,55,100,3, +31.2500,off,60,0,2, +31.2500,off,69,0,0, +31.2500,on,70,100,0, +31.2500,on,62,100,2, +31.5000,off,70,0,0, +31.5000,off,62,0,2, +31.5000,on,69,100,0, +31.5000,on,60,100,2, +31.7500,off,69,0,0, +31.7500,off,60,0,2, +31.7500,on,67,100,0, +31.7500,on,58,100,2, +32.0000,off,55,0,3, +32.0000,off,58,0,2, +32.0000,on,57,100,2, +32.0000,on,50,100,3, +32.2500,off,67,0,0, +32.2500,on,64,100,0, +32.5000,off,64,0,0, +32.5000,on,65,100,0, +32.7500,off,65,0,0, +32.7500,on,62,100,0, +33.0000,off,62,0,0, +33.0000,on,70,100,0, +33.2500,off,57,0,2, +33.2500,on,53,100,2, +33.5000,off,50,0,3, +33.5000,off,53,0,2, +33.5000,on,55,100,2, +33.5000,on,52,100,3, +33.7500,off,52,0,3, +33.7500,on,50,100,3, +34.0000,off,55,0,2, +34.0000,off,50,0,3, +34.0000,on,60,100,2, +34.0000,on,52,100,3, +34.2500,off,70,0,0, +34.2500,on,67,100,0, +34.5000,off,52,0,3, +34.5000,off,67,0,0, +34.5000,on,69,100,0, +34.5000,on,53,100,3, +34.7500,off,53,0,3, +34.7500,on,52,100,3, +35.0000,off,69,0,0, +35.0000,off,52,0,3, +35.0000,on,74,100,0, +35.0000,on,54,100,3, +35.2500,off,60,0,2, +35.2500,on,57,100,2, +35.5000,off,54,0,3, +35.5000,off,57,0,2, +35.5000,on,59,100,2, +35.5000,on,55,100,3, +35.7500,off,55,0,3, +35.7500,on,54,100,3, +36.0000,off,59,0,2, +36.0000,off,54,0,3, +36.0000,on,64,100,2, +36.0000,on,56,100,3, +36.2500,off,74,0,0, +36.2500,on,71,100,0, +36.5000,off,56,0,3, +36.5000,off,71,0,0, +36.5000,on,72,100,0, +36.5000,on,57,100,3, +36.7500,off,57,0,3, +36.7500,on,56,100,3, +37.0000,off,72,0,0, +37.0000,off,56,0,3, +37.0000,on,77,100,0, +37.0000,on,57,100,3, +37.2500,off,64,0,2, +37.2500,on,61,100,2, +37.5000,off,57,0,3, +37.5000,off,61,0,2, +37.5000,on,62,100,2, +37.5000,on,58,100,3, +37.7500,off,58,0,3, +37.7500,on,57,100,3, +38.0000,off,62,0,2, +38.0000,off,57,0,3, +38.0000,on,67,100,2, +38.0000,on,59,100,3, +38.2500,off,77,0,0, +38.2500,on,74,100,0, +38.5000,off,59,0,3, +38.5000,off,74,0,0, +38.5000,on,76,100,0, +38.5000,on,60,100,3, +38.7500,off,60,0,3, +38.7500,on,59,100,3, +39.0000,off,76,0,0, +39.0000,off,59,0,3, +39.0000,on,69,100,0, +39.0000,on,61,100,3, +39.2500,off,67,0,2, +39.2500,on,64,100,2, +39.5000,off,69,0,0, +39.5000,off,61,0,3, +39.5000,off,64,0,2, +39.5000,on,74,100,0, +39.5000,on,65,100,2, +39.5000,on,62,100,3, +39.7500,off,62,0,3, +39.7500,on,56,100,3, +40.0000,off,65,0,2, +40.0000,off,56,0,3, +40.0000,on,64,100,2, +40.0000,on,57,100,3, +40.2500,off,74,0,0, +40.2500,on,71,100,0, +40.5000,off,71,0,0, +40.5000,on,72,100,0, +40.7500,off,64,0,2, +40.7500,on,69,100,2, +41.0000,off,72,0,0, +41.0000,off,69,0,2, +41.0000,on,65,100,0, +41.0000,on,62,100,2, +41.2500,off,57,0,3, +41.2500,on,53,100,3, +41.5000,off,65,0,0, +41.5000,off,53,0,3, +41.5000,on,70,100,0, +41.5000,on,55,100,3, +41.7500,off,62,0,2, +41.7500,on,64,100,2, +42.0000,off,70,0,0, +42.0000,off,64,0,2, +42.0000,on,69,100,0, +42.0000,on,61,100,2, +42.2500,off,55,0,3, +42.2500,on,52,100,3, +42.5000,off,61,0,2, +42.5000,off,52,0,3, +42.5000,on,62,100,2, +42.5000,on,53,100,3, +42.7500,off,62,0,2, +42.7500,on,57,100,2, +43.0000,off,69,0,0, +43.0000,off,57,0,2, +43.0000,on,62,100,0, +43.0000,on,59,100,2, +43.2500,off,53,0,3, +43.2500,on,50,100,3, +43.5000,off,62,0,0, +43.5000,off,50,0,3, +43.5000,on,67,100,0, +43.5000,on,52,100,3, +43.7500,off,59,0,2, +43.7500,on,61,100,2, +44.0000,off,52,0,3, +44.0000,off,61,0,2, +44.0000,on,62,100,1, +44.0000,on,62,100,2, +44.0000,on,50,100,3, +44.2500,off,67,0,0, +44.2500,on,64,100,0, +44.5000,off,62,0,2, +44.5000,off,64,0,0, +44.5000,on,65,100,0, +44.5000,on,57,100,2, +44.7500,off,65,0,0, +44.7500,on,74,100,0, +45.0000,off,62,0,1, +45.0000,off,74,0,0, +45.0000,on,64,100,0, +45.0000,on,69,100,1, +45.2500,off,50,0,3, +45.2500,on,47,100,3, +45.5000,off,47,0,3, +45.5000,on,49,100,3, +46.0000,off,69,0,1, +46.0000,off,49,0,3, +46.0000,on,65,100,1, +46.0000,on,50,100,3, +46.2500,off,64,0,0, +46.2500,on,62,100,0, +46.5000,off,62,0,0, +46.5000,on,69,100,0, +46.7500,off,50,0,3, +46.7500,on,48,100,3, +47.0000,off,57,0,2, +47.0000,off,65,0,1, +47.0000,off,48,0,3, +47.0000,on,62,100,1, +47.0000,on,58,100,2, +47.0000,on,46,100,3, +47.5000,off,69,0,0, +47.5000,on,67,100,0, +48.0000,off,62,0,1, +48.0000,off,58,0,2, +48.0000,off,46,0,3, +48.0000,off,67,0,0, +48.0000,on,69,100,0, +48.0000,on,61,100,1, +48.0000,on,45,100,3, +48.2500,on,52,100,2, +48.5000,off,52,0,2, +48.5000,on,57,100,2, +48.7500,off,45,0,3, +48.7500,on,43,100,3, +49.0000,off,69,0,0, +49.0000,off,61,0,1, +49.0000,off,43,0,3, +49.0000,on,62,100,1, +49.0000,on,41,100,3, +49.2500,off,57,0,2, +49.2500,off,41,0,3, +49.2500,on,58,100,2, +49.2500,on,43,100,3, +49.5000,off,62,0,1, +49.5000,off,58,0,2, +49.5000,off,43,0,3, +49.5000,on,64,100,1, +49.5000,on,57,100,2, +49.5000,on,41,100,3, +49.7500,off,57,0,2, +49.7500,off,41,0,3, +49.7500,on,55,100,2, +49.7500,on,40,100,3, +50.0000,off,64,0,1, +50.0000,off,55,0,2, +50.0000,off,40,0,3, +50.0000,on,65,100,1, +50.0000,on,57,100,2, +50.0000,on,38,100,3, +50.2500,off,38,0,3, +50.2500,on,41,100,3, +50.5000,off,57,0,2, +50.5000,off,41,0,3, +50.5000,on,59,100,2, +50.5000,on,40,100,3, +50.7500,off,40,0,3, +50.7500,on,38,100,3, +51.0000,off,59,0,2, +51.0000,off,38,0,3, +51.0000,on,60,100,2, +51.0000,on,45,100,3, +51.2500,off,65,0,1, +51.2500,on,67,100,1, +51.5000,off,67,0,1, +51.5000,on,65,100,1, +51.7500,off,45,0,3, +51.7500,off,65,0,1, +51.7500,on,64,100,1, +51.7500,on,41,100,3, +52.0000,off,64,0,1, +52.0000,off,41,0,3, +52.0000,on,62,100,1, +52.0000,on,46,100,3, +52.2500,off,60,0,2, +52.2500,on,57,100,2, +52.5000,off,62,0,1, +52.5000,off,57,0,2, +52.5000,on,67,100,1, +52.5000,on,58,100,2, +52.7500,off,46,0,3, +52.7500,on,43,100,3, +53.0000,off,58,0,2, +53.0000,off,43,0,3, +53.0000,on,57,100,2, +53.0000,on,50,100,3, +53.2500,off,67,0,1, +53.2500,on,64,100,1, +53.5000,off,57,0,2, +53.5000,off,64,0,1, +53.5000,on,65,100,1, +53.5000,on,62,100,2, +53.7500,off,50,0,3, +53.7500,on,53,100,3, +54.0000,off,65,0,1, +54.0000,off,53,0,3, +54.0000,on,64,100,1, +54.0000,on,57,100,3, +54.2500,off,62,0,2, +54.2500,on,59,100,2, +54.5000,off,64,0,1, +54.5000,off,59,0,2, +54.5000,on,69,100,1, +54.5000,on,60,100,2, +54.7500,off,57,0,3, +54.7500,on,45,100,3, +55.0000,off,60,0,2, +55.0000,off,45,0,3, +55.0000,on,59,100,2, +55.0000,on,40,100,3, +55.2500,off,69,0,1, +55.2500,on,66,100,1, +55.5000,off,59,0,2, +55.5000,off,66,0,1, +55.5000,on,67,100,1, +55.5000,on,64,100,2, +56.0000,off,40,0,3, +56.0000,off,67,0,1, +56.0000,on,69,100,0, +56.0000,on,66,100,1, +56.2500,off,64,0,2, +56.2500,on,57,100,2, +56.5000,off,57,0,2, +56.5000,on,62,100,2, +56.7500,off,66,0,1, +56.7500,on,74,100,1, +57.0000,off,69,0,0, +57.0000,off,74,0,1, +57.0000,on,76,100,0, +57.0000,on,68,100,1, +57.0000,on,52,100,3, +57.2500,off,62,0,2, +57.2500,on,62,100,2, +57.5000,off,62,0,2, +57.5000,on,60,100,2, +57.7500,off,60,0,2, +57.7500,on,59,100,2, +58.0000,off,76,0,0, +58.0000,off,68,0,1, +58.0000,off,52,0,3, +58.0000,off,59,0,2, +58.0000,on,72,100,0, +58.0000,on,69,100,1, +58.0000,on,60,100,2, +58.0000,on,57,100,3, +58.2500,off,60,0,2, +58.2500,on,62,100,2, +58.5000,off,69,0,1, +58.5000,off,62,0,2, +58.5000,on,64,100,2, +58.7500,on,57,100,1, +59.0000,off,72,0,0, +59.0000,off,57,0,3, +59.0000,off,57,0,1, +59.0000,on,69,100,0, +59.0000,on,60,100,1, +59.0000,on,53,100,3, +59.2500,off,64,0,2, +59.2500,on,64,100,2, +59.5000,off,60,0,1, +59.5000,off,64,0,2, +59.5000,on,57,100,1, +59.5000,on,62,100,2, +59.7500,off,62,0,2, +59.7500,on,60,100,2, +60.0000,off,69,0,0, +60.0000,off,57,0,1, +60.0000,off,60,0,2, +60.0000,on,68,100,0, +60.0000,on,62,100,1, +60.0000,on,59,100,2, +60.2500,off,53,0,3, +60.2500,on,53,100,3, +60.5000,off,62,0,1, +60.5000,off,53,0,3, +60.5000,on,65,100,1, +60.5000,on,52,100,3, +60.7500,off,52,0,3, +60.7500,on,50,100,3, +61.0000,off,68,0,0, +61.0000,off,59,0,2, +61.0000,off,65,0,1, +61.0000,off,50,0,3, +61.0000,on,69,100,0, +61.0000,on,64,100,1, +61.0000,on,60,100,2, +61.0000,on,48,100,3, +61.2500,off,48,0,3, +61.2500,on,50,100,3, +61.5000,off,69,0,0, +61.5000,off,64,0,1, +61.5000,off,60,0,2, +61.5000,off,50,0,3, +61.5000,on,71,100,0, +61.5000,on,62,100,1, +61.5000,on,56,100,2, +61.5000,on,48,100,3, +61.7500,off,48,0,3, +61.7500,on,47,100,3, +62.0000,off,71,0,0, +62.0000,off,62,0,1, +62.0000,off,56,0,2, +62.0000,off,47,0,3, +62.0000,on,72,100,0, +62.0000,on,60,100,1, +62.0000,on,57,100,2, +62.0000,on,45,100,3, +62.2500,off,57,0,2, +62.2500,on,55,100,2, +62.5000,off,60,0,1, +62.5000,off,55,0,2, +62.5000,on,69,100,1, +62.5000,on,54,100,2, +62.7500,off,54,0,2, +62.7500,on,52,100,2, +63.0000,off,45,0,3, +63.0000,off,52,0,2, +63.0000,on,54,100,2, +63.0000,on,50,100,3, +63.2500,off,72,0,0, +63.2500,on,74,100,0, +63.5000,off,69,0,1, +63.5000,off,54,0,2, +63.5000,off,74,0,0, +63.5000,on,72,100,0, +63.5000,on,62,100,1, +63.5000,on,55,100,2, +63.7500,off,72,0,0, +63.7500,on,70,100,0, +64.0000,off,50,0,3, +64.0000,off,62,0,1, +64.0000,off,70,0,0, +64.0000,on,69,100,0, +64.0000,on,64,100,1, +64.0000,on,49,100,3, +64.2500,off,55,0,2, +64.2500,on,55,100,2, +64.5000,off,69,0,0, +64.5000,off,64,0,1, +64.5000,off,55,0,2, +64.5000,on,69,100,1, +64.5000,on,53,100,2, +64.7500,off,53,0,2, +64.7500,on,52,100,2, +65.0000,off,49,0,3, +65.0000,off,52,0,2, +65.0000,on,53,100,2, +65.0000,on,45,100,3, +65.2500,off,69,0,1, +65.2500,off,53,0,2, +65.2500,on,67,100,1, +65.2500,on,52,100,2, +65.5000,off,67,0,1, +65.5000,off,52,0,2, +65.5000,on,69,100,0, +65.5000,on,65,100,1, +65.5000,on,50,100,2, +65.7500,off,65,0,1, +65.7500,off,50,0,2, +65.7500,on,64,100,1, +65.7500,on,49,100,2, +66.0000,off,45,0,3, +66.0000,off,64,0,1, +66.0000,off,49,0,2, +66.0000,on,62,100,1, +66.0000,on,50,100,2, +66.0000,on,42,100,3, +66.2500,off,69,0,0, +66.2500,on,72,100,0, +66.5000,off,50,0,2, +66.5000,off,72,0,0, +66.5000,on,70,100,0, +66.7500,off,70,0,0, +66.7500,on,69,100,0, +67.0000,off,42,0,3, +67.0000,off,69,0,0, +67.0000,on,70,100,0, +67.0000,on,43,100,3, +67.2500,off,70,0,0, +67.2500,on,69,100,0, +67.5000,off,43,0,3, +67.5000,off,69,0,0, +67.5000,on,67,100,0, +67.5000,on,45,100,3, +67.7500,off,67,0,0, +67.7500,on,66,100,0, +68.0000,off,45,0,3, +68.0000,off,66,0,0, +68.0000,on,67,100,0, +68.0000,on,46,100,3, +68.2500,off,62,0,1, +68.2500,on,62,100,1, +68.5000,off,62,0,1, +68.5000,on,67,100,1, +68.7500,off,67,0,0, +68.7500,on,70,100,0, +69.0000,off,70,0,0, +69.0000,on,64,100,0, +69.2500,off,46,0,3, +69.2500,off,67,0,1, +69.2500,on,67,100,1, +69.2500,on,48,100,3, +69.5000,off,67,0,1, +69.5000,off,48,0,3, +69.5000,on,60,100,1, +69.5000,on,46,100,3, +69.7500,off,64,0,0, +69.7500,off,46,0,3, +69.7500,on,66,100,0, +69.7500,on,45,100,3, +70.0000,off,66,0,0, +70.0000,off,45,0,3, +70.0000,on,67,100,0, +70.0000,on,43,100,3, +70.2500,off,60,0,1, +70.2500,on,57,100,1, +70.5000,off,57,0,1, +70.5000,on,58,100,1, +70.7500,off,67,0,0, +70.7500,on,64,100,0, +71.0000,off,58,0,1, +71.0000,off,64,0,0, +71.0000,on,61,100,0, +71.0000,on,57,100,1, +71.2500,off,43,0,3, +71.2500,on,40,100,3, +71.5000,off,40,0,3, +71.5000,on,41,100,3, +71.7500,off,61,0,0, +71.7500,on,69,100,0, +72.0000,off,41,0,3, +72.0000,off,69,0,0, +72.0000,on,62,100,0, +72.0000,on,46,100,3, +72.2500,off,57,0,1, +72.2500,on,53,100,1, +72.5000,off,53,0,1, +72.5000,on,55,100,1, +72.7500,off,62,0,0, +72.7500,on,65,100,0, +73.0000,off,55,0,1, +73.0000,off,65,0,0, +73.0000,on,64,100,0, +73.0000,on,60,100,1, +73.2500,off,46,0,3, +73.2500,on,43,100,3, +73.5000,off,43,0,3, +73.5000,on,45,100,3, +73.7500,off,64,0,0, +73.7500,on,72,100,0, +74.0000,off,45,0,3, +74.0000,off,72,0,0, +74.0000,on,65,100,0, +74.0000,on,50,100,3, +74.2500,off,60,0,1, +74.2500,on,57,100,1, +74.5000,off,57,0,1, +74.5000,on,59,100,1, +74.7500,off,65,0,0, +74.7500,on,69,100,0, +75.0000,off,59,0,1, +75.0000,off,69,0,0, +75.0000,on,67,100,0, +75.0000,on,64,100,1, +75.2500,off,50,0,3, +75.2500,on,47,100,3, +75.5000,off,47,0,3, +75.5000,on,48,100,3, +75.7500,off,67,0,0, +75.7500,on,76,100,0, +76.0000,off,48,0,3, +76.0000,off,76,0,0, +76.0000,on,69,100,0, +76.0000,on,53,100,3, +76.2500,off,64,0,1, +76.2500,on,61,100,1, +76.5000,off,61,0,1, +76.5000,on,62,100,1, +76.7500,off,69,0,0, +76.7500,on,72,100,0, +77.0000,off,62,0,1, +77.0000,off,72,0,0, +77.0000,on,71,100,0, +77.0000,on,67,100,1, +77.2500,off,53,0,3, +77.2500,on,50,100,3, +77.5000,off,50,0,3, +77.5000,on,52,100,3, +77.7500,off,71,0,0, +77.7500,on,79,100,0, +78.0000,off,52,0,3, +78.0000,off,79,0,0, +78.0000,on,73,100,0, +78.0000,on,52,100,2, +78.0000,on,45,100,3, +78.2500,off,67,0,1, +78.2500,on,69,100,1, +78.5000,off,69,0,1, +78.5000,on,70,100,1, +78.7500,off,45,0,3, +78.7500,on,55,100,3, +79.0000,off,73,0,0, +79.0000,off,52,0,2, +79.0000,off,70,0,1, +79.0000,off,55,0,3, +79.0000,on,74,100,0, +79.0000,on,69,100,1, +79.0000,on,57,100,2, +79.0000,on,53,100,3, +79.2500,off,53,0,3, +79.2500,on,52,100,3, +79.5000,off,74,0,0, +79.5000,off,52,0,3, +79.5000,on,76,100,0, +79.5000,on,50,100,3, +79.7500,off,50,0,3, +79.7500,on,49,100,3, +80.0000,off,57,0,2, +80.0000,off,49,0,3, +80.0000,on,53,100,2, +80.0000,on,50,100,3, +80.2500,off,76,0,0, +80.2500,on,73,100,0, +80.5000,off,73,0,0, +80.5000,on,74,100,0, +80.7500,off,50,0,3, +80.7500,on,41,100,3, +81.0000,off,53,0,2, +81.0000,off,41,0,3, +81.0000,on,50,100,2, +81.0000,on,46,100,3, +81.2500,off,69,0,1, +81.2500,on,65,100,1, +81.5000,off,65,0,1, +81.5000,on,67,100,1, +81.7500,off,74,0,0, +81.7500,on,76,100,0, +82.0000,off,50,0,2, +82.0000,off,46,0,3, +82.0000,off,67,0,1, +82.0000,off,76,0,0, +82.0000,on,77,100,0, +82.0000,on,69,100,1, +82.0000,on,49,100,2, +82.0000,on,45,100,3, +82.2500,off,77,0,0, +82.2500,on,76,100,0, +82.5000,off,76,0,0, +82.5000,on,79,100,0, +82.7500,off,69,0,1, +82.7500,on,70,100,1, +83.0000,off,49,0,2, +83.0000,off,70,0,1, +83.0000,on,69,100,1, +83.0000,on,50,100,2, +83.2500,off,79,0,0, +83.2500,on,77,100,0, +83.5000,off,69,0,1, +83.5000,off,50,0,2, +83.5000,off,77,0,0, +83.5000,on,76,100,0, +83.5000,on,67,100,1, +83.5000,on,52,100,2, +83.7500,off,76,0,0, +83.7500,on,74,100,0, +84.0000,off,52,0,2, +84.0000,off,74,0,0, +84.0000,on,73,100,0, +84.0000,on,53,100,2, +84.2500,off,73,0,0, +84.2500,on,69,100,0, +84.5000,off,67,0,1, +84.5000,off,69,0,0, +84.5000,on,74,100,0, +84.5000,on,65,100,1, +84.7500,off,45,0,3, +84.7500,off,65,0,1, +84.7500,on,62,100,1, +84.7500,on,46,100,3, +85.0000,off,62,0,1, +85.0000,off,46,0,3, +85.0000,on,69,100,1, +85.0000,on,45,100,3, +85.2500,off,53,0,2, +85.2500,off,74,0,0, +85.2500,off,45,0,3, +85.2500,on,71,100,0, +85.2500,on,55,100,2, +85.2500,on,43,100,3, +85.5000,off,71,0,0, +85.5000,off,55,0,2, +85.5000,off,43,0,3, +85.5000,on,72,100,0, +85.5000,on,53,100,2, +85.5000,on,45,100,3, +85.7500,off,69,0,1, +85.7500,off,53,0,2, +85.7500,on,67,100,1, +85.7500,on,52,100,2, +86.0000,off,72,0,0, +86.0000,off,45,0,3, +86.0000,off,67,0,1, +86.0000,off,52,0,2, +86.0000,on,72,100,0, +86.0000,on,66,100,1, +86.0000,on,50,100,2, +86.0000,on,46,100,3, +86.2500,off,66,0,1, +86.2500,on,62,100,1, +86.5000,off,72,0,0, +86.5000,off,62,0,1, +86.5000,on,70,100,0, +86.5000,on,67,100,1, +86.7500,off,46,0,3, +86.7500,on,43,100,3, +87.0000,off,70,0,0, +87.0000,off,43,0,3, +87.0000,on,69,100,0, +87.0000,on,50,100,3, +87.2500,off,67,0,1, +87.2500,on,64,100,1, +87.5000,off,50,0,2, +87.5000,off,69,0,0, +87.5000,off,64,0,1, +87.5000,on,65,100,1, +87.5000,on,57,100,2, +87.7500,off,57,0,2, +87.7500,on,53,100,2, +88.0000,off,53,0,2, +88.0000,on,58,100,2, +88.2500,off,65,0,1, +88.2500,on,62,100,1, +88.5000,off,50,0,3, +88.5000,off,62,0,1, +88.5000,on,67,100,1, +88.5000,on,52,100,3, +88.7500,off,58,0,2, +88.7500,on,55,100,2, +89.0000,off,55,0,2, +89.0000,on,60,100,2, +89.2500,off,67,0,1, +89.2500,on,64,100,1, +89.5000,off,52,0,3, +89.5000,off,64,0,1, +89.5000,on,69,100,1, +89.5000,on,53,100,3, +89.7500,off,60,0,2, +89.7500,on,57,100,2, +90.0000,off,57,0,2, +90.0000,on,62,100,2, +90.2500,off,69,0,1, +90.2500,on,65,100,1, +90.5000,off,62,0,2, +90.5000,off,65,0,1, +90.5000,on,70,100,1, +90.5000,on,55,100,2, +90.7500,off,53,0,3, +90.7500,on,50,100,3, +91.0000,off,55,0,2, +91.0000,off,50,0,3, +91.0000,on,60,100,2, +91.0000,on,52,100,3, +91.2500,off,70,0,1, +91.2500,on,67,100,1, +91.5000,off,60,0,2, +91.5000,off,67,0,1, +91.5000,on,69,100,1, +91.5000,on,53,100,2, +91.7500,off,52,0,3, +91.7500,on,49,100,3, +92.0000,off,53,0,2, +92.0000,off,49,0,3, +92.0000,on,58,100,2, +92.0000,on,50,100,3, +92.2500,off,69,0,1, +92.2500,on,65,100,1, +92.5000,off,58,0,2, +92.5000,off,65,0,1, +92.5000,on,67,100,1, +92.5000,on,52,100,2, +92.7500,off,50,0,3, +92.7500,on,47,100,3, +93.0000,off,52,0,2, +93.0000,off,47,0,3, +93.0000,on,57,100,2, +93.0000,on,49,100,3, +93.2500,off,49,0,3, +93.2500,on,45,100,3, +93.5000,off,67,0,1, +93.5000,off,45,0,3, +93.5000,on,65,100,1, +93.5000,on,50,100,3, +93.7500,off,65,0,1, +93.7500,on,62,100,1, +94.0000,off,57,0,2, +94.0000,off,62,0,1, +94.0000,on,69,100,1, +94.0000,on,52,100,2, +94.2500,off,50,0,3, +94.2500,on,48,100,3, +94.5000,off,52,0,2, +94.5000,off,48,0,3, +94.5000,on,57,100,2, +94.5000,on,47,100,3, +94.7500,off,47,0,3, +94.7500,on,45,100,3, +95.0000,off,69,0,1, +95.0000,off,45,0,3, +95.0000,on,74,100,1, +95.0000,on,47,100,3, +95.2500,off,57,0,2, +95.2500,on,56,100,2, +95.5000,off,56,0,2, +95.5000,on,54,100,2, +95.7500,off,54,0,2, +95.7500,on,56,100,2, +96.0000,off,47,0,3, +96.0000,off,56,0,2, +96.0000,on,76,100,0, +96.0000,on,57,100,2, +96.0000,on,45,100,3, +96.2500,off,74,0,1, +96.2500,on,73,100,1, +96.5000,off,45,0,3, +96.5000,off,73,0,1, +96.5000,on,71,100,1, +96.7500,off,57,0,2, +96.7500,off,71,0,1, +96.7500,on,73,100,1, +96.7500,on,55,100,2, +97.0000,off,76,0,0, +97.0000,off,73,0,1, +97.0000,off,55,0,2, +97.0000,on,81,100,0, +97.0000,on,74,100,1, +97.0000,on,53,100,2, +97.2500,off,74,0,1, +97.2500,off,53,0,2, +97.2500,on,69,100,1, +97.2500,on,52,100,2, +97.5000,off,69,0,1, +97.5000,off,52,0,2, +97.5000,on,76,100,1, +97.5000,on,50,100,2, +97.7500,off,50,0,2, +97.7500,on,49,100,2, +98.0000,off,81,0,0, +98.0000,off,49,0,2, +98.0000,on,77,100,0, +98.0000,on,50,100,2, +98.2500,off,76,0,1, +98.2500,on,69,100,1, +98.5000,off,50,0,2, +98.5000,off,69,0,1, +98.5000,on,74,100,1, +98.5000,on,53,100,2, +98.7500,off,53,0,2, +98.7500,on,50,100,2, +99.0000,off,77,0,0, +99.0000,off,74,0,1, +99.0000,off,50,0,2, +99.0000,on,74,100,0, +99.0000,on,58,100,2, +99.2500,on,65,100,1, +99.5000,off,58,0,2, +99.5000,off,65,0,1, +99.5000,on,70,100,1, +99.5000,on,55,100,2, +99.7500,off,55,0,2, +99.7500,on,52,100,2, +100.0000,off,74,0,0, +100.0000,off,52,0,2, +100.0000,on,73,100,0, +100.0000,on,57,100,2, +100.2500,off,70,0,1, +100.2500,on,64,100,1, +100.5000,off,64,0,1, +100.5000,on,69,100,1, +100.7500,off,57,0,2, +100.7500,on,65,100,2, +101.0000,off,73,0,0, +101.0000,off,65,0,2, +101.0000,on,74,100,0, +101.0000,on,59,100,2, +101.2500,off,69,0,1, +101.2500,on,67,100,1, +101.5000,off,74,0,0, +101.5000,off,59,0,2, +101.5000,off,67,0,1, +101.5000,on,76,100,0, +101.5000,on,65,100,1, +101.5000,on,61,100,2, +101.7500,off,65,0,1, +101.7500,on,64,100,1, +102.0000,off,76,0,0, +102.0000,off,61,0,2, +102.0000,off,64,0,1, +102.0000,on,77,100,0, +102.0000,on,62,100,1, +102.0000,on,62,100,2, +102.2500,off,62,0,1, +102.2500,on,69,100,1, +102.5000,off,62,0,2, +102.5000,off,69,0,1, +102.5000,on,74,100,1, +102.5000,on,59,100,2, +102.7500,off,74,0,1, +102.7500,off,59,0,2, +102.7500,on,71,100,1, +102.7500,on,55,100,2, +103.0000,off,71,0,1, +103.0000,off,55,0,2, +103.0000,on,67,100,1, +103.0000,on,60,100,2, +103.2500,off,77,0,0, +103.2500,off,67,0,1, +103.2500,on,79,100,0, +103.2500,on,64,100,1, +103.5000,off,60,0,2, +103.5000,off,79,0,0, +103.5000,off,64,0,1, +103.5000,on,77,100,0, +103.5000,on,72,100,1, +103.5000,on,57,100,2, +103.7500,off,77,0,0, +103.7500,off,57,0,2, +103.7500,on,76,100,0, +103.7500,on,53,100,2, +104.0000,off,76,0,0, +104.0000,off,53,0,2, +104.0000,on,74,100,0, +104.0000,on,58,100,2, +104.2500,off,58,0,2, +104.2500,on,62,100,2, +104.5000,off,72,0,1, +104.5000,off,62,0,2, +104.5000,on,70,100,1, +104.5000,on,67,100,2, +104.7500,off,74,0,0, +104.7500,on,76,100,0, +105.0000,off,70,0,1, +105.0000,off,76,0,0, +105.0000,on,73,100,0, +105.0000,on,69,100,1, +105.2500,off,67,0,2, +105.2500,on,64,100,2, +105.5000,off,73,0,0, +105.5000,off,64,0,2, +105.5000,on,74,100,0, +105.5000,on,65,100,2, +105.7500,off,74,0,0, +105.7500,on,77,100,0, +106.0000,off,69,0,1, +106.0000,off,77,0,0, +106.0000,on,70,100,0, +106.0000,on,67,100,1, +106.2500,off,65,0,2, +106.2500,on,65,100,2, +106.5000,off,65,0,2, +106.5000,on,64,100,2, +106.7500,off,67,0,1, +106.7500,off,64,0,2, +106.7500,on,65,100,1, +106.7500,on,62,100,2, +107.0000,off,65,0,1, +107.0000,off,62,0,2, +107.0000,on,64,100,1, +107.0000,on,61,100,2, +107.2500,off,70,0,0, +107.2500,on,70,100,0, +107.5000,off,70,0,0, +107.5000,on,69,100,0, +107.7500,off,69,0,0, +107.7500,on,67,100,0, +108.0000,off,61,0,2, +108.0000,off,67,0,0, +108.0000,on,65,100,0, +108.0000,on,62,100,2, +108.2500,off,62,0,2, +108.2500,on,60,100,2, +108.5000,off,64,0,1, +108.5000,off,60,0,2, +108.5000,on,62,100,1, +108.5000,on,58,100,2, +108.7500,off,62,0,1, +108.7500,off,58,0,2, +108.7500,on,61,100,1, +108.7500,on,57,100,2, +109.0000,off,65,0,0, +109.0000,off,61,0,1, +109.0000,off,57,0,2, +109.0000,on,70,100,0, +109.0000,on,62,100,1, +109.0000,on,55,100,2, +109.2500,off,55,0,2, +109.2500,on,57,100,2, +109.5000,off,62,0,1, +109.5000,off,57,0,2, +109.5000,on,67,100,1, +109.5000,on,58,100,2, +109.7500,off,58,0,2, +109.7500,on,60,100,2, +110.0000,off,70,0,0, +110.0000,off,60,0,2, +110.0000,on,69,100,0, +110.0000,on,62,100,2, +110.0000,on,50,100,3, +110.2500,off,62,0,2, +110.2500,on,57,100,2, +110.5000,off,57,0,2, +110.5000,on,62,100,2, +110.7500,off,67,0,1, +110.7500,on,65,100,1, +111.0000,off,50,0,3, +111.0000,off,65,0,1, +111.0000,on,64,100,1, +111.0000,on,57,100,3, +111.2500,off,62,0,2, +111.2500,on,59,100,2, +111.5000,off,69,0,0, +111.5000,off,59,0,2, +111.5000,on,76,100,0, +111.5000,on,61,100,2, +111.7500,off,64,0,1, +111.7500,on,64,100,1, +112.0000,off,57,0,3, +112.0000,off,64,0,1, +112.0000,on,69,100,1, +112.0000,on,53,100,3, +112.2500,off,76,0,0, +112.2500,off,61,0,2, +112.2500,on,73,100,0, +112.2500,on,64,100,2, +112.5000,off,73,0,0, +112.5000,off,64,0,2, +112.5000,on,74,100,0, +112.5000,on,57,100,2, +112.7500,off,74,0,0, +112.7500,off,57,0,2, +112.7500,on,76,100,0, +112.7500,on,61,100,2, +113.0000,off,53,0,3, +113.0000,off,76,0,0, +113.0000,off,61,0,2, +113.0000,on,77,100,0, +113.0000,on,62,100,2, +113.0000,on,50,100,3, +113.2500,off,77,0,0, +113.2500,on,74,100,0, +113.5000,off,69,0,1, +113.5000,off,62,0,2, +113.5000,off,74,0,0, +113.5000,on,79,100,0, +113.5000,on,67,100,1, +113.5000,on,58,100,2, +113.7500,off,67,0,1, +113.7500,off,58,0,2, +113.7500,on,70,100,1, +113.7500,on,55,100,2, +114.0000,off,50,0,3, +114.0000,off,70,0,1, +114.0000,off,55,0,2, +114.0000,on,69,100,1, +114.0000,on,52,100,2, +114.0000,on,49,100,3, +114.2500,off,79,0,0, +114.2500,on,76,100,0, +114.5000,off,76,0,0, +114.5000,on,81,100,0, +114.7500,off,81,0,0, +114.7500,on,79,100,0, +115.0000,off,52,0,2, +115.0000,off,49,0,3, +115.0000,off,79,0,0, +115.0000,on,77,100,0, +115.0000,on,53,100,2, +115.0000,on,50,100,3, +115.2500,off,69,0,1, +115.2500,off,77,0,0, +115.2500,on,76,100,0, +115.2500,on,67,100,1, +115.5000,off,53,0,2, +115.5000,off,50,0,3, +115.5000,off,76,0,0, +115.5000,off,67,0,1, +115.5000,on,74,100,0, +115.5000,on,65,100,1, +115.5000,on,55,100,2, +115.5000,on,52,100,3, +115.7500,off,74,0,0, +115.7500,off,65,0,1, +115.7500,on,73,100,0, +115.7500,on,64,100,1, +116.0000,off,55,0,2, +116.0000,off,52,0,3, +116.0000,off,73,0,0, +116.0000,off,64,0,1, +116.0000,on,74,100,0, +116.0000,on,62,100,1, +116.0000,on,57,100,2, +116.0000,on,53,100,3, +116.2500,off,74,0,0, +116.2500,on,72,100,0, +116.5000,off,72,0,0, +116.5000,on,70,100,0, +116.7500,off,70,0,0, +116.7500,on,69,100,0, +117.0000,off,57,0,2, +117.0000,off,69,0,0, +117.0000,on,67,100,0, +117.0000,on,59,100,2, +117.2500,off,53,0,3, +117.2500,on,55,100,3, +117.5000,off,62,0,1, +117.5000,off,59,0,2, +117.5000,off,55,0,3, +117.5000,on,64,100,1, +117.5000,on,61,100,2, +117.5000,on,53,100,3, +117.7500,off,53,0,3, +117.7500,on,52,100,3, +118.0000,off,64,0,1, +118.0000,off,61,0,2, +118.0000,off,52,0,3, +118.0000,on,57,100,1, +118.0000,on,62,100,2, +118.0000,on,50,100,3, +118.2500,off,67,0,0, +118.2500,on,64,100,0, +118.5000,off,57,0,1, +118.5000,off,62,0,2, +118.5000,off,64,0,0, +118.5000,on,65,100,0, +118.7500,off,65,0,0, +118.7500,on,62,100,0, +119.0000,off,62,0,0, +119.0000,on,69,100,0, +119.2500,off,50,0,3, +119.2500,on,51,100,3, +119.5000,off,51,0,3, +119.5000,on,63,100,1, +119.5000,on,54,100,2, +119.5000,on,50,100,3, +119.7500,off,50,0,3, +119.7500,on,48,100,3, +120.0000,off,63,0,1, +120.0000,off,54,0,2, +120.0000,off,48,0,3, +120.0000,on,62,100,1, +120.0000,on,55,100,2, +120.0000,on,46,100,3, +120.2500,off,69,0,0, +120.2500,off,55,0,2, +120.2500,on,66,100,0, +120.2500,on,57,100,2, +120.5000,off,66,0,0, +120.5000,off,57,0,2, +120.5000,on,67,100,0, +120.5000,on,58,100,2, +120.7500,off,67,0,0, +120.7500,on,70,100,0, +121.0000,off,62,0,1, +121.0000,off,58,0,2, +121.0000,off,70,0,0, +121.0000,on,72,100,0, +121.2500,off,46,0,3, +121.2500,on,48,100,3, +121.5000,off,48,0,3, +121.5000,on,66,100,1, +121.5000,on,60,100,2, +121.5000,on,46,100,3, +121.7500,off,46,0,3, +121.7500,on,45,100,3, +122.0000,off,66,0,1, +122.0000,off,60,0,2, +122.0000,off,45,0,3, +122.0000,on,67,100,1, +122.0000,on,62,100,2, +122.0000,on,43,100,3, +122.2500,off,72,0,0, +122.2500,off,67,0,1, +122.2500,on,69,100,0, +122.2500,on,66,100,1, +122.5000,off,69,0,0, +122.5000,off,66,0,1, +122.5000,on,70,100,0, +122.5000,on,67,100,1, +122.7500,off,70,0,0, +122.7500,on,74,100,0, +123.0000,off,62,0,2, +123.0000,off,67,0,1, +123.0000,off,74,0,0, +123.0000,on,75,100,0, +123.2500,on,55,100,2, +123.5000,off,43,0,3, +123.5000,off,75,0,0, +123.5000,on,74,100,0, +123.5000,on,70,100,1, +123.5000,on,43,100,3, +123.7500,off,55,0,2, +123.7500,on,53,100,2, +124.0000,off,74,0,0, +124.0000,off,53,0,2, +124.0000,on,73,100,0, +124.0000,on,52,100,2, +124.2500,off,70,0,1, +124.2500,on,69,100,1, +124.5000,off,73,0,0, +124.5000,off,69,0,1, +124.5000,on,81,100,0, +124.5000,on,77,100,1, +124.7500,off,77,0,1, +124.7500,on,74,100,1, +125.0000,off,52,0,2, +125.0000,off,74,0,1, +125.0000,on,71,100,1, +125.2500,off,81,0,0, +125.2500,on,74,100,0, +125.5000,off,71,0,1, +125.5000,off,74,0,0, +125.5000,on,79,100,0, +125.5000,on,76,100,1, +125.7500,off,76,0,1, +125.7500,on,73,100,1, +126.0000,off,73,0,1, +126.0000,on,69,100,1, +126.2500,off,79,0,0, +126.2500,on,73,100,0, +126.5000,off,69,0,1, +126.5000,off,73,0,0, +126.5000,on,77,100,0, +126.5000,on,74,100,1, +126.5000,on,53,100,2, +126.7500,off,74,0,1, +126.7500,off,53,0,2, +126.7500,on,69,100,1, +126.7500,on,50,100,2, +127.0000,off,69,0,1, +127.0000,off,50,0,2, +127.0000,on,70,100,1, +127.0000,on,55,100,2, +127.2500,off,77,0,0, +127.2500,on,74,100,0, +127.5000,off,74,0,0, +127.5000,on,76,100,0, +127.7500,off,70,0,1, +127.7500,off,55,0,2, +127.7500,on,67,100,1, +127.7500,on,49,100,2, +128.0000,off,67,0,1, +128.0000,off,49,0,2, +128.0000,on,69,100,1, +128.0000,on,53,100,2, +128.2500,off,76,0,0, +128.2500,on,73,100,0, +128.5000,off,73,0,0, +128.5000,on,74,100,0, +128.7500,off,69,0,1, +128.7500,off,53,0,2, +128.7500,on,65,100,1, +128.7500,on,50,100,2, +129.0000,off,65,0,1, +129.0000,off,50,0,2, +129.0000,on,64,100,1, +129.0000,on,57,100,2, +129.2500,off,74,0,0, +129.2500,on,71,100,0, +129.5000,off,43,0,3, +129.5000,off,71,0,0, +129.5000,on,72,100,0, +129.5000,on,45,100,3, +129.7500,off,64,0,1, +129.7500,on,67,100,1, +130.0000,off,57,0,2, +130.0000,off,45,0,3, +130.0000,off,67,0,1, +130.0000,on,66,100,1, +130.0000,on,50,100,2, +130.0000,on,46,100,3, +130.2500,off,66,0,1, +130.2500,on,62,100,1, +130.5000,off,72,0,0, +130.5000,off,50,0,2, +130.5000,off,62,0,1, +130.5000,on,70,100,0, +130.5000,on,67,100,1, +130.5000,on,62,100,2, +130.7500,off,46,0,3, +130.7500,on,43,100,3, +131.0000,off,70,0,0, +131.0000,off,43,0,3, +131.0000,on,69,100,0, +131.0000,on,50,100,3, +131.2500,off,67,0,1, +131.2500,on,64,100,1, +131.5000,off,62,0,2, +131.5000,off,64,0,1, +131.5000,on,65,100,1, +131.5000,on,57,100,2, +131.7500,off,69,0,0, +131.7500,off,57,0,2, +131.7500,on,69,100,0, +131.7500,on,53,100,2, +132.0000,off,69,0,0, +132.0000,off,53,0,2, +132.0000,on,74,100,0, +132.0000,on,58,100,2, +132.2500,off,50,0,3, +132.2500,off,65,0,1, +132.2500,off,74,0,0, +132.2500,on,77,100,0, +132.2500,on,74,100,1, +132.2500,on,46,100,3, +132.5000,off,77,0,0, +132.5000,off,74,0,1, +132.5000,off,46,0,3, +132.5000,on,76,100,0, +132.5000,on,72,100,1, +132.5000,on,48,100,3, +132.7500,off,76,0,0, +132.7500,on,79,100,0, +133.0000,off,48,0,3, +133.0000,off,79,0,0, +133.0000,on,77,100,0, +133.0000,on,53,100,3, +133.2500,off,58,0,2, +133.2500,off,77,0,0, +133.2500,on,76,100,0, +133.2500,on,56,100,2, +133.5000,off,76,0,0, +133.5000,off,56,0,2, +133.5000,on,74,100,0, +133.5000,on,57,100,2, +133.7500,off,72,0,1, +133.7500,on,72,100,1, +134.0000,off,57,0,2, +134.0000,off,72,0,1, +134.0000,on,70,100,1, +134.0000,on,62,100,2, +134.2500,off,53,0,3, +134.2500,off,74,0,0, +134.2500,off,70,0,1, +134.2500,on,77,100,0, +134.2500,on,69,100,1, +134.2500,on,50,100,3, +134.5000,off,69,0,1, +134.5000,off,50,0,3, +134.5000,on,68,100,1, +134.5000,on,52,100,3, +134.7500,off,77,0,0, +134.7500,on,76,100,0, +135.0000,off,68,0,1, +135.0000,off,52,0,3, +135.0000,off,76,0,0, +135.0000,on,77,100,0, +135.0000,on,69,100,1, +135.0000,on,57,100,3, +135.2500,off,62,0,2, +135.2500,off,77,0,0, +135.2500,on,74,100,0, +135.2500,on,59,100,2, +135.5000,off,74,0,0, +135.5000,off,59,0,2, +135.5000,on,76,100,0, +135.5000,on,60,100,2, +135.7500,off,69,0,1, +135.7500,on,64,100,1, +136.0000,off,60,0,2, +136.0000,off,64,0,1, +136.0000,on,69,100,1, +136.0000,on,65,100,2, +136.2500,off,57,0,3, +136.2500,off,76,0,0, +136.2500,on,74,100,0, +136.2500,on,53,100,3, +136.5000,off,69,0,1, +136.5000,off,74,0,0, +136.5000,off,53,0,3, +136.5000,on,72,100,0, +136.5000,on,67,100,1, +136.5000,on,55,100,3, +136.7500,off,72,0,0, +136.7500,on,71,100,0, +137.0000,off,55,0,3, +137.0000,off,71,0,0, +137.0000,on,72,100,0, +137.0000,on,60,100,3, +137.2500,off,65,0,2, +137.2500,on,62,100,2, +137.5000,off,62,0,2, +137.5000,on,63,100,2, +137.7500,off,67,0,1, +137.7500,off,72,0,0, +137.7500,on,81,100,0, +137.7500,on,72,100,1, +138.0000,off,63,0,2, +138.0000,off,81,0,0, +138.0000,off,72,0,1, +138.0000,on,79,100,0, +138.0000,on,69,100,1, +138.0000,on,62,100,2, +138.2500,off,60,0,3, +138.2500,off,79,0,0, +138.2500,on,78,100,0, +138.2500,on,57,100,3, +138.5000,off,69,0,1, +138.5000,off,78,0,0, +138.5000,off,57,0,3, +138.5000,on,79,100,0, +138.5000,on,67,100,1, +138.5000,on,58,100,3, +138.7500,off,79,0,0, +138.7500,on,82,100,0, +139.0000,off,62,0,2, +139.0000,off,82,0,0, +139.0000,on,73,100,0, +139.0000,on,64,100,2, +139.5000,off,67,0,1, +139.5000,off,58,0,3, +139.5000,off,73,0,0, +139.5000,off,64,0,2, +141.0000,on,74,100,0, +141.0000,on,69,100,1, +141.0000,on,65,100,2, +141.0000,on,57,100,3, +141.5000,off,74,0,0, +141.5000,off,69,0,1, +141.5000,off,65,0,2, +141.5000,off,57,0,3, +143.0000,on,74,100,0, +143.0000,on,71,100,1, +143.0000,on,65,100,2, +143.0000,on,56,100,3, +144.0000,off,71,0,1, +144.0000,off,56,0,3, +144.0000,on,69,100,1, +144.0000,on,57,100,3, +144.5000,off,65,0,2, +144.5000,on,64,100,2, +144.7500,off,64,0,2, +144.7500,on,62,100,2, +145.0000,off,62,0,2, +145.0000,on,64,100,2, +145.2500,off,74,0,0, +145.2500,on,71,100,0, +145.5000,off,57,0,3, +145.5000,off,64,0,2, +145.5000,off,71,0,0, +145.5000,on,73,100,0, +145.5000,on,45,100,3, +145.7500,off,69,0,1, +145.7500,on,67,100,1, +146.0000,off,73,0,0, +146.0000,off,45,0,3, +146.0000,off,67,0,1, +146.0000,on,74,100,0, +146.0000,on,66,100,1, +146.0000,on,57,100,2, +146.0000,on,50,100,3, +146.2500,off,66,0,1, +146.2500,on,67,100,1, +146.5000,off,67,0,1, +146.5000,on,69,100,1, +146.7500,off,74,0,0, +146.7500,on,72,100,0, +147.0000,off,57,0,2, +147.0000,off,72,0,0, +147.0000,on,70,100,0, +147.0000,on,62,100,2, +147.2500,off,69,0,1, +147.2500,on,67,100,1, +147.5000,off,67,0,1, +147.5000,on,72,100,1, +147.7500,off,70,0,0, +147.7500,on,69,100,0, +148.0000,off,62,0,2, +148.0000,off,69,0,0, +148.0000,on,62,100,0, +148.0000,on,58,100,2, +148.2500,off,72,0,1, +148.2500,on,66,100,1, +148.5000,off,66,0,1, +148.5000,on,67,100,1, +148.7500,off,67,0,1, +148.7500,on,70,100,1, +149.0000,off,62,0,0, +149.0000,off,58,0,2, +149.0000,off,70,0,1, +149.0000,on,63,100,1, +149.0000,on,55,100,2, +149.2500,on,67,100,0, +149.5000,off,67,0,0, +149.5000,on,69,100,0, +149.7500,off,69,0,0, +149.7500,on,72,100,0, +150.0000,off,63,0,1, +150.0000,off,55,0,2, +150.0000,on,62,100,1, +150.0000,on,54,100,2, +150.2500,off,72,0,0, +150.2500,on,70,100,0, +150.5000,off,62,0,1, +150.5000,off,70,0,0, +150.5000,on,72,100,0, +150.5000,on,57,100,1, +150.7500,off,72,0,0, +150.7500,on,75,100,0, +151.0000,off,54,0,2, +151.0000,off,57,0,1, +151.0000,on,58,100,1, +151.0000,on,55,100,2, +151.2500,off,75,0,0, +151.2500,on,74,100,0, +151.5000,off,58,0,1, +151.5000,off,55,0,2, +151.5000,off,74,0,0, +151.5000,on,78,100,0, +151.5000,on,60,100,1, +151.5000,on,57,100,2, +151.7500,off,78,0,0, +151.7500,on,81,100,0, +152.0000,off,60,0,1, +152.0000,off,57,0,2, +152.0000,on,62,100,1, +152.0000,on,58,100,2, +152.2500,off,81,0,0, +152.2500,on,79,100,0, +152.3750,off,79,0,0, +152.3750,on,81,100,0, +152.5000,off,62,0,1, +152.5000,off,81,0,0, +152.5000,on,82,100,0, +152.5000,on,55,100,1, +152.7500,off,82,0,0, +152.7500,on,73,100,0, +153.0000,off,73,0,0, +153.0000,on,74,100,0, +153.2500,off,58,0,2, +153.2500,off,55,0,1, +153.2500,on,70,100,1, +153.2500,on,62,100,2, +153.5000,off,70,0,1, +153.5000,off,62,0,2, +153.5000,on,69,100,1, +153.5000,on,60,100,2, +153.7500,off,69,0,1, +153.7500,off,60,0,2, +153.7500,on,67,100,1, +153.7500,on,58,100,2, +154.0000,off,58,0,2, +154.0000,on,57,100,2, +154.2500,off,67,0,1, +154.2500,on,66,100,1, +154.5000,off,57,0,2, +154.5000,off,66,0,1, +154.5000,on,64,100,1, +154.5000,on,57,100,2, +154.7500,off,64,0,1, +154.7500,on,67,100,1, +155.0000,off,67,0,1, +155.0000,on,66,100,1, +156.0000,off,50,0,3, +156.0000,off,74,0,0, +156.0000,off,57,0,2, +156.0000,off,66,0,1, diff --git a/data/dot/euler-j5-a.dot b/data/dot/euler-j5-a.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler-j5-a.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_3 [label="A♮\n5:3"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_16_9 [label="B♭\n16:9"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_64_45 [label="F♯\n64:45"]; +R_16_15 [label="C♯\n16:15"]; +R_8_5 [label="A♭\n8:5"]; +R_6_5 [label="E♭\n6:5"]; +R_5_3 -- R_5_4 -- R_15_8; +R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8; +R_64_45 -- R_16_15 -- R_8_5 -- R_6_5; +R_4_3 -- R_5_3 [label=" (8:5)"]; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_64_45 -- R_16_9 [label=" (8:5)"]; +R_16_15 -- R_4_3 [label=" (8:5)"]; +R_8_5 -- R_1_1 [label=" (8:5)"]; +R_6_5 -- R_3_2 [label=" (8:5)"]; +{rank=min; R_5_3 R_5_4 R_15_8} +{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8} +{rank=max; R_64_45 R_16_15 R_8_5 R_6_5} +} diff --git a/data/dot/euler-j5-b.dot b/data/dot/euler-j5-b.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler-j5-b.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_3 [label="A♮\n5:3"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_45_32 [label="F♯\n45:32"]; +R_16_9 [label="B♭\n16:9"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_16_15 [label="C♯\n16:15"]; +R_8_5 [label="A♭\n8:5"]; +R_6_5 [label="E♭\n6:5"]; +R_5_3 -- R_5_4 -- R_15_8 -- R_45_32; +R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8; +R_16_15 -- R_8_5 -- R_6_5; +R_4_3 -- R_5_3 [label=" (8:5)"]; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_9_8 -- R_45_32 [label=" (8:5)"]; +R_16_15 -- R_4_3 [label=" (8:5)"]; +R_8_5 -- R_1_1 [label=" (8:5)"]; +R_6_5 -- R_3_2 [label=" (8:5)"]; +{rank=min; R_5_3 R_5_4 R_15_8 R_45_32} +{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8} +{rank=max; R_16_15 R_8_5 R_6_5} +} diff --git a/data/dot/euler-j7.dot b/data/dot/euler-j7.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler-j7.dot @@ -0,0 +1,29 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_45_32 [label="F♯\n45:32"]; +R_135_128 [label="C♯\n135:128"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_27_16 [label="A♮\n27:16"]; +R_14_9 [label="A♭\n14:9"]; +R_7_6 [label="E♭\n7:6"]; +R_7_4 [label="B♭\n7:4"]; +R_5_4 -- R_15_8 -- R_45_32 -- R_135_128; +R_4_3 -- R_1_1 -- R_3_2 -- R_9_8 -- R_27_16; +R_14_9 -- R_7_6 -- R_7_4; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_9_8 -- R_45_32 [label=" (8:5)"]; +R_27_16 -- R_135_128 [label=" (8:5)"]; +R_7_6 -- R_4_3 [label=" (7:4)"]; +R_7_4 -- R_1_1 [label=" (7:4)"]; +{rank=min; R_5_4 R_15_8 R_45_32 R_135_128} +{rank=same; R_4_3 R_1_1 R_3_2 R_9_8 R_27_16} +{rank=max; R_14_9 R_7_6 R_7_4} +} diff --git a/data/dot/euler-wtp.dot b/data/dot/euler-wtp.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler-wtp.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_49_32 [label="B♭=738\n49:32"]; +R_147_128 [label="F♮=240\n147:128"]; +R_441_256 [label="C♮=942\n441:256"]; +R_1323_1024 [label="G♮=444\n1323:1024"]; +R_7_4 [label="C♯=969\n7:4"]; +R_21_16 [label="A♭=471\n21:16"]; +R_63_32 [label="E♭=1173\n63:32"]; +R_189_128 [label="B♭=675\n189:128"]; +R_567_512 [label="F♮=177\n567:512"]; +R_1_1 [label="E♭=0\n1:1"]; +R_3_2 [label="B♭=702\n3:2"]; +R_9_8 [label="F♮=204\n9:8"]; +R_49_32 -- R_147_128 -- R_441_256 -- R_1323_1024; +R_7_4 -- R_21_16 -- R_63_32 -- R_189_128 -- R_567_512; +R_1_1 -- R_3_2 -- R_9_8; +R_7_4 -- R_49_32 [label=" (8:7)"]; +R_21_16 -- R_147_128 [label=" (8:7)"]; +R_63_32 -- R_441_256 [label=" (8:7)"]; +R_189_128 -- R_1323_1024 [label=" (8:7)"]; +R_1_1 -- R_7_4 [label=" (8:7)"]; +R_3_2 -- R_21_16 [label=" (8:7)"]; +R_9_8 -- R_63_32 [label=" (8:7)"]; +{rank=min; R_49_32 R_147_128 R_441_256 R_1323_1024} +{rank=same; R_7_4 R_21_16 R_63_32 R_189_128 R_567_512} +{rank=max; R_1_1 R_3_2 R_9_8} +} diff --git a/data/dot/tj_oh_p012.dot b/data/dot/tj_oh_p012.dot new file mode 100644 --- /dev/null +++ b/data/dot/tj_oh_p012.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_3 [label="A♮=884\n5:3"]; +R_5_4 [label="E♮=386\n5:4"]; +R_15_8 [label="B♮=1088\n15:8"]; +R_45_32 [label="F♯=590\n45:32"]; +R_16_9 [label="B♭=996\n16:9"]; +R_4_3 [label="F♮=498\n4:3"]; +R_1_1 [label="C♮=0\n1:1"]; +R_3_2 [label="G♮=702\n3:2"]; +R_9_8 [label="D♮=204\n9:8"]; +R_16_15 [label="C♯=112\n16:15"]; +R_8_5 [label="A♭=814\n8:5"]; +R_6_5 [label="E♭=316\n6:5"]; +R_5_3 -- R_5_4 -- R_15_8 -- R_45_32; +R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8; +R_16_15 -- R_8_5 -- R_6_5; +R_4_3 -- R_5_3 [label=" (8:5)"]; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_9_8 -- R_45_32 [label=" (8:5)"]; +R_16_15 -- R_4_3 [label=" (8:5)"]; +R_8_5 -- R_1_1 [label=" (8:5)"]; +R_6_5 -- R_3_2 [label=" (8:5)"]; +{rank=min; R_5_3 R_5_4 R_15_8 R_45_32} +{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8} +{rank=max; R_16_15 R_8_5 R_6_5} +} diff --git a/data/dot/tj_oh_p014.dot b/data/dot/tj_oh_p014.dot new file mode 100644 --- /dev/null +++ b/data/dot/tj_oh_p014.dot @@ -0,0 +1,58 @@ +graph + g { +graph [start=168732,layout=neato,epsilon=0.000001]; +node [shape=plaintext,fontsize=10,fontname="century schoolbook"]; +0 [label="C♮"]; +1 [label="c♮"]; +2 [label="C♯"]; +3 [label="c♯"]; +4 [label="D♮"]; +5 [label="d♮"]; +6 [label="E♭"]; +7 [label="e♭"]; +8 [label="E♮"]; +9 [label="e♮"]; +10 [label="F♮"]; +11 [label="f♮"]; +12 [label="F♯"]; +13 [label="f♯"]; +14 [label="G♮"]; +15 [label="g♮"]; +16 [label="A♭"]; +17 [label="a♭"]; +18 [label="A♮"]; +19 [label="a♮"]; +20 [label="B♮"]; +21 [label="b♮"]; +22 [label="b♭"]; +23 [label="B♭"]; +0 -- 1; +0 -- 9; +0 -- 19; +2 -- 3; +2 -- 11; +2 -- 22; +4 -- 5; +4 -- 21; +6 -- 1; +6 -- 7; +6 -- 15; +8 -- 3; +8 -- 9; +8 -- 17; +10 -- 11; +12 -- 13; +12 -- 22; +14 -- 9; +14 -- 15; +14 -- 21; +16 -- 11; +16 -- 17; +18 -- 3; +18 -- 13; +18 -- 19; +20 -- 17; +20 -- 21; +23 -- 5; +23 -- 15; +} diff --git a/data/dot/tj_oh_p031.dot b/data/dot/tj_oh_p031.dot new file mode 100644 --- /dev/null +++ b/data/dot/tj_oh_p031.dot @@ -0,0 +1,53 @@ +graph + g { +graph [layout=neato,epsilon=0.000001]; +node [shape=plaintext,fontsize=10,fontname="century schoolbook"]; +0 [label="0,2,4,7"]; +1 [label="0,2,7,10"]; +2 [label="0,2,4,9"]; +3 [label="1,3,5,8"]; +4 [label="1,3,8,11"]; +5 [label="1,3,5,10"]; +6 [label="2,4,6,9"]; +7 [label="2,4,6,11"]; +8 [label="0,5,7,9"]; +9 [label="2,5,7,9"]; +10 [label="1,6,8,10"]; +11 [label="3,6,8,10"]; +12 [label="2,7,9,11"]; +13 [label="4,7,9,11"]; +14 [label="0,3,8,10"]; +15 [label="0,5,8,10"]; +16 [label="1,4,9,11"]; +17 [label="1,6,9,11"]; +18 [label="0,2,5,10"]; +19 [label="1,3,6,11"]; +20 [label="3,5,7,10"]; +21 [label="4,6,8,11"]; +22 [label="0,3,5,7"]; +23 [label="1,4,6,8"]; +0 -- 1; +0 -- 2; +2 -- 6; +3 -- 4; +3 -- 5; +5 -- 20; +6 -- 7; +7 -- 21; +8 -- 9; +9 -- 12; +10 -- 11; +12 -- 13; +14 -- 11; +14 -- 15; +16 -- 13; +16 -- 17; +18 -- 1; +18 -- 15; +19 -- 4; +19 -- 17; +22 -- 8; +22 -- 20; +23 -- 10; +23 -- 21; +} diff --git a/data/dot/tj_oh_p125.dot b/data/dot/tj_oh_p125.dot new file mode 100644 --- /dev/null +++ b/data/dot/tj_oh_p125.dot @@ -0,0 +1,72 @@ +graph + g { +graph [layout=neato,epsilon=0.000001]; +node [shape=plaintext,fontsize=10,fontname="century schoolbook"]; +0 [label="0,4,11"]; +1 [label="0,5,11"]; +2 [label="1,4,11"]; +3 [label="0,5,10"]; +4 [label="0,6,10"]; +5 [label="1,5,10"]; +6 [label="0,6,9"]; +7 [label="0,7,9"]; +8 [label="1,6,9"]; +9 [label="0,7,8"]; +10 [label="1,7,8"]; +11 [label="1,3,11"]; +12 [label="2,3,11"]; +13 [label="1,4,10"]; +14 [label="2,4,10"]; +15 [label="1,5,9"]; +16 [label="2,5,9"]; +17 [label="1,6,8"]; +18 [label="2,6,8"]; +19 [label="2,3,10"]; +20 [label="2,4,9"]; +21 [label="3,4,9"]; +22 [label="2,5,8"]; +23 [label="3,5,8"]; +24 [label="2,6,7"]; +25 [label="3,6,7"]; +26 [label="3,4,8"]; +27 [label="3,5,7"]; +28 [label="4,5,7"]; +29 [label="4,5,6"]; +0 -- 1; +0 -- 2; +3 -- 1; +3 -- 4; +3 -- 5; +6 -- 4; +6 -- 7; +6 -- 8; +9 -- 7; +9 -- 10; +11 -- 2; +11 -- 12; +13 -- 2; +13 -- 5; +13 -- 14; +15 -- 5; +15 -- 8; +15 -- 16; +17 -- 8; +17 -- 10; +17 -- 18; +19 -- 12; +19 -- 14; +20 -- 14; +20 -- 16; +20 -- 21; +22 -- 16; +22 -- 18; +22 -- 23; +24 -- 18; +24 -- 25; +26 -- 21; +26 -- 23; +27 -- 23; +27 -- 25; +27 -- 28; +29 -- 28; +} diff --git a/data/dot/tj_oh_p131.dot b/data/dot/tj_oh_p131.dot new file mode 100644 --- /dev/null +++ b/data/dot/tj_oh_p131.dot @@ -0,0 +1,26 @@ +graph + g { +graph [layout=neato,epsilon=0.000001]; +node [shape=plaintext,fontsize=10,fontname="century schoolbook"]; +0 [label="6,10,14"]; +1 [label="6,11,13"]; +2 [label="7,9,14"]; +3 [label="7,10,13"]; +4 [label="7,11,12"]; +5 [label="8,9,13"]; +6 [label="8,10,12"]; +7 [label="9,10,11"]; +0 -- 1; +0 -- 2; +0 -- 3; +1 -- 3; +1 -- 4; +2 -- 3; +2 -- 5; +3 -- 4; +3 -- 5; +3 -- 6; +4 -- 6; +5 -- 6; +6 -- 7; +} diff --git a/data/dot/tj_oh_p162.dot b/data/dot/tj_oh_p162.dot new file mode 100644 --- /dev/null +++ b/data/dot/tj_oh_p162.dot @@ -0,0 +1,83 @@ +graph + g { +edge [len=1.75]; +graph [layout=neato,epsilon=0.000001]; +node [shape=plaintext,fontsize=10,fontname="century schoolbook"]; +0 [label="0,1,2,6"]; +1 [label="0,2,5,6"]; +2 [label="1,2,4,6"]; +3 [label="1,2,6,8"]; +4 [label="0,1,3,5"]; +5 [label="0,1,5,7"]; +6 [label="1,3,4,5"]; +7 [label="1,3,5,8"]; +8 [label="0,1,4,8"]; +9 [label="0,4,5,8"]; +10 [label="1,4,5,7"]; +11 [label="1,5,7,8"]; +12 [label="0,2,3,4"]; +13 [label="0,2,3,8"]; +14 [label="0,2,4,7"]; +15 [label="0,3,4,6"]; +16 [label="2,3,4,8"]; +17 [label="0,2,7,8"]; +18 [label="0,3,6,8"]; +19 [label="0,4,6,7"]; +20 [label="2,4,7,8"]; +21 [label="2,4,5,6"]; +22 [label="2,5,6,8"]; +23 [label="0,6,7,8"]; +24 [label="3,4,6,8"]; +25 [label="4,6,7,8"]; +26 [label="1,2,3,7"]; +27 [label="1,3,6,7"]; +28 [label="2,3,5,7"]; +29 [label="3,5,6,7"]; +0 -- 1; +0 -- 2; +0 -- 3; +1 -- 21; +1 -- 22; +2 -- 3; +2 -- 21; +3 -- 22; +4 -- 5; +4 -- 6; +4 -- 7; +5 -- 10; +5 -- 11; +6 -- 7; +6 -- 10; +7 -- 11; +8 -- 9; +10 -- 11; +12 -- 13; +12 -- 14; +12 -- 15; +12 -- 16; +13 -- 16; +13 -- 17; +13 -- 18; +14 -- 17; +14 -- 19; +14 -- 20; +15 -- 18; +15 -- 19; +15 -- 24; +16 -- 20; +16 -- 24; +17 -- 20; +17 -- 23; +18 -- 23; +18 -- 24; +19 -- 23; +19 -- 25; +20 -- 25; +21 -- 22; +23 -- 25; +24 -- 25; +26 -- 27; +26 -- 28; +27 -- 29; +28 -- 29; +} diff --git a/data/scl/dr_itb_etude_1.scl b/data/scl/dr_itb_etude_1.scl new file mode 100644 --- /dev/null +++ b/data/scl/dr_itb_etude_1.scl @@ -0,0 +1,41 @@ +! dr_itb_etude_1.scl +! +... +36 +! +1/1 +1/1 +1/1 +1/1 +4/3 +16/11 +16/11 +8/5 +8/5 +16/9 +16/9 +2/1 +2/1 +16/7 +16/7 +16/7 +8/3 +8/3 +3/1 +16/5 +16/5 +32/9 +32/9 +4/1 +4/1 +9/2 +9/2 +5/1 +16/3 +11/2 +6/1 +32/5 +32/5 +7/1 +7/1 +8/1 diff --git a/data/scl/et12.scl b/data/scl/et12.scl new file mode 100644 --- /dev/null +++ b/data/scl/et12.scl @@ -0,0 +1,17 @@ +! et12.scl +! +12 tone equal temperament +12 +! +100.0 +200.0 +300.0 +400.0 +500.0 +600.0 +700.0 +800.0 +900.0 +1000.0 +1100.0 +2/1 diff --git a/data/scl/et19.scl b/data/scl/et19.scl new file mode 100644 --- /dev/null +++ b/data/scl/et19.scl @@ -0,0 +1,24 @@ +! et19.scl +! +19 tone equal temperament +19 +! +63.1578947368421 +126.3157894736842 +189.4736842105263 +252.63157894736838 +315.78947368421046 +378.94736842105254 +442.1052631578946 +505.2631578947367 +568.4210526315787 +631.5789473684208 +694.7368421052629 +757.894736842105 +821.0526315789471 +884.2105263157891 +947.3684210526312 +1010.5263157894733 +1073.6842105263154 +1136.8421052631575 +2/1 diff --git a/data/scl/et31.scl b/data/scl/et31.scl new file mode 100644 --- /dev/null +++ b/data/scl/et31.scl @@ -0,0 +1,36 @@ +! et31.scl +! +31 tone equal temperament +31 +! +38.70967741935484 +77.41935483870968 +116.12903225806451 +154.83870967741933 +193.54838709677415 +232.25806451612897 +270.9677419354838 +309.6774193548386 +348.3870967741934 +387.09677419354824 +425.80645161290306 +464.5161290322579 +503.2258064516127 +541.9354838709676 +580.6451612903224 +619.3548387096773 +658.0645161290322 +696.7741935483871 +735.483870967742 +774.1935483870968 +812.9032258064517 +851.6129032258066 +890.3225806451615 +929.0322580645163 +967.7419354838712 +1006.4516129032261 +1045.161290322581 +1083.8709677419358 +1122.5806451612907 +1161.2903225806456 +2/1 diff --git a/data/scl/et53.scl b/data/scl/et53.scl new file mode 100644 --- /dev/null +++ b/data/scl/et53.scl @@ -0,0 +1,58 @@ +! et53.scl +! +53 tone equal temperament +53 +! +22.641509433962263 +45.283018867924525 +67.9245283018868 +90.56603773584906 +113.20754716981133 +135.8490566037736 +158.49056603773585 +181.1320754716981 +203.77358490566036 +226.4150943396226 +249.05660377358487 +271.6981132075471 +294.3396226415094 +316.98113207547163 +339.6226415094339 +362.26415094339615 +384.9056603773584 +407.54716981132066 +430.1886792452829 +452.83018867924517 +475.4716981132074 +498.1132075471697 +520.7547169811319 +543.3962264150941 +566.0377358490564 +588.6792452830186 +611.3207547169809 +633.9622641509432 +656.6037735849054 +679.2452830188677 +701.8867924528299 +724.5283018867922 +747.1698113207544 +769.8113207547167 +792.452830188679 +815.0943396226412 +837.7358490566035 +860.3773584905657 +883.018867924528 +905.6603773584902 +928.3018867924525 +950.9433962264147 +973.584905660377 +996.2264150943392 +1018.8679245283015 +1041.5094339622638 +1064.150943396226 +1086.7924528301883 +1109.4339622641505 +1132.0754716981128 +1154.716981132075 +1177.3584905660373 +2/1 diff --git a/data/scl/et72.scl b/data/scl/et72.scl new file mode 100644 --- /dev/null +++ b/data/scl/et72.scl @@ -0,0 +1,77 @@ +! et72.scl +! +72 tone equal temperament +72 +! +16.666666666666668 +33.333333333333336 +50.0 +66.66666666666666 +83.33333333333331 +99.99999999999997 +116.66666666666663 +133.3333333333333 +149.99999999999994 +166.6666666666666 +183.33333333333326 +199.99999999999991 +216.66666666666657 +233.33333333333323 +249.9999999999999 +266.6666666666665 +283.33333333333314 +299.9999999999998 +316.6666666666664 +333.33333333333303 +349.99999999999966 +366.6666666666663 +383.3333333333329 +399.99999999999955 +416.6666666666662 +433.3333333333328 +449.99999999999943 +466.66666666666606 +483.3333333333327 +499.9999999999993 +516.666666666666 +533.3333333333326 +549.9999999999992 +566.6666666666658 +583.3333333333325 +599.9999999999991 +616.6666666666657 +633.3333333333323 +649.999999999999 +666.6666666666656 +683.3333333333322 +699.9999999999989 +716.6666666666655 +733.3333333333321 +749.9999999999987 +766.6666666666654 +783.333333333332 +799.9999999999986 +816.6666666666653 +833.3333333333319 +849.9999999999985 +866.6666666666652 +883.3333333333318 +899.9999999999984 +916.666666666665 +933.3333333333317 +949.9999999999983 +966.6666666666649 +983.3333333333316 +999.9999999999982 +1016.6666666666648 +1033.3333333333314 +1049.9999999999982 +1066.666666666665 +1083.3333333333317 +1099.9999999999984 +1116.6666666666652 +1133.333333333332 +1149.9999999999986 +1166.6666666666654 +1183.3333333333321 +2/1 diff --git a/data/scl/et96.scl b/data/scl/et96.scl new file mode 100644 --- /dev/null +++ b/data/scl/et96.scl @@ -0,0 +1,101 @@ +! et96.scl +! +96 tone equal temperament +96 +! +12.5 +25.0 +37.5 +50.0 +62.5 +75.0 +87.5 +100.0 +112.5 +125.0 +137.5 +150.0 +162.5 +175.0 +187.5 +200.0 +212.5 +225.0 +237.5 +250.0 +262.5 +275.0 +287.5 +300.0 +312.5 +325.0 +337.5 +350.0 +362.5 +375.0 +387.5 +400.0 +412.5 +425.0 +437.5 +450.0 +462.5 +475.0 +487.5 +500.0 +512.5 +525.0 +537.5 +550.0 +562.5 +575.0 +587.5 +600.0 +612.5 +625.0 +637.5 +650.0 +662.5 +675.0 +687.5 +700.0 +712.5 +725.0 +737.5 +750.0 +762.5 +775.0 +787.5 +800.0 +812.5 +825.0 +837.5 +850.0 +862.5 +875.0 +887.5 +900.0 +912.5 +925.0 +937.5 +950.0 +962.5 +975.0 +987.5 +1000.0 +1012.5 +1025.0 +1037.5 +1050.0 +1062.5 +1075.0 +1087.5 +1100.0 +1112.5 +1125.0 +1137.5 +1150.0 +1162.5 +1175.0 +1187.5 +2/1 diff --git a/data/scl/hs17.scl b/data/scl/hs17.scl new file mode 100644 --- /dev/null +++ b/data/scl/hs17.scl @@ -0,0 +1,22 @@ +! hs17.scl +! +17 tone harmonic series +17 +! +2/1 +3/1 +4/1 +5/1 +6/1 +7/1 +8/1 +9/1 +10/1 +11/1 +12/1 +13/1 +14/1 +15/1 +16/1 +17/1 +2/1 diff --git a/data/scl/hs19.scl b/data/scl/hs19.scl new file mode 100644 --- /dev/null +++ b/data/scl/hs19.scl @@ -0,0 +1,24 @@ +! hs19.scl +! +19 tone harmonic series +19 +! +2/1 +3/1 +4/1 +5/1 +6/1 +7/1 +8/1 +9/1 +10/1 +11/1 +12/1 +13/1 +14/1 +15/1 +16/1 +17/1 +18/1 +19/1 +2/1 diff --git a/data/scl/hs21.scl b/data/scl/hs21.scl new file mode 100644 --- /dev/null +++ b/data/scl/hs21.scl @@ -0,0 +1,26 @@ +! hs21.scl +! +21 tone harmonic series +21 +! +2/1 +3/1 +4/1 +5/1 +6/1 +7/1 +8/1 +9/1 +10/1 +11/1 +12/1 +13/1 +14/1 +15/1 +16/1 +17/1 +18/1 +19/1 +20/1 +21/1 +2/1 diff --git a/data/scl/hs23.scl b/data/scl/hs23.scl new file mode 100644 --- /dev/null +++ b/data/scl/hs23.scl @@ -0,0 +1,28 @@ +! hs23.scl +! +23 tone harmonic series +23 +! +2/1 +3/1 +4/1 +5/1 +6/1 +7/1 +8/1 +9/1 +10/1 +11/1 +12/1 +13/1 +14/1 +15/1 +16/1 +17/1 +18/1 +19/1 +20/1 +21/1 +22/1 +23/1 +2/1 diff --git a/data/scl/young-lm_piano_1964.scl b/data/scl/young-lm_piano_1964.scl new file mode 100644 --- /dev/null +++ b/data/scl/young-lm_piano_1964.scl @@ -0,0 +1,17 @@ +! young-lm_piano_1964.scl +! +LaMonte Young's Well-Tuned Piano (1964) +12 +! +279/256 +9/8 +147/128 +21/16 +93/64 +189/128 +3/2 +49/32 +7/4 +31/16 +63/32 +2/1 diff --git a/hmt.cabal b/hmt.cabal --- a/hmt.cabal +++ b/hmt.cabal @@ -1,48 +1,65 @@ Name: hmt -Version: 0.15 +Version: 0.16 Synopsis: Haskell Music Theory Description: Haskell music theory library License: GPL Category: Music -Copyright: Rohan Drape, 2006-2014 +Copyright: Rohan Drape, 2006-2017 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental Homepage: http://rd.slavepianos.org/t/hmt -Tested-With: GHC == 7.8.2 +Tested-With: GHC == 8.0.1 Build-Type: Simple Cabal-Version: >= 1.8 Data-files: README - Help/hmt.help.lhs + data/csv/mnd/*.csv + data/dot/*.dot + data/scl/*.scl Library - Build-Depends: array, - base == 4.*, + Build-Depends: aeson, + array, + base >= 4.8 && < 5, bytestring, colour, containers, data-ordlist, directory, + fgl, filepath, lazy-csv, logict, + modular-arithmetic, multiset-comb, parsec, permutation, primes, + random, safe, split, - utf8-string + text GHC-Options: -Wall -fwarn-tabs - Exposed-modules: Music.Theory.Array.CSV - Music.Theory.Array.CSV.Midi + Exposed-modules: Music.Theory.Array + Music.Theory.Array.Cell_Ref + Music.Theory.Array.CSV + Music.Theory.Array.CSV.Midi.MND + Music.Theory.Array.Direction Music.Theory.Array.MD + Music.Theory.Bits Music.Theory.Bjorklund Music.Theory.Block_Design.Johnson_2007 + Music.Theory.Braille + Music.Theory.Byte Music.Theory.Clef Music.Theory.Combinations Music.Theory.Contour.Polansky_1992 + Music.Theory.DB.Common + Music.Theory.DB.CSV + Music.Theory.DB.JSON + Music.Theory.DB.Plain + Music.Theory.Directory Music.Theory.Duration Music.Theory.Duration.Annotation Music.Theory.Duration.CT @@ -54,30 +71,52 @@ Music.Theory.Duration.Sequence.Notate Music.Theory.Dynamic_Mark Music.Theory.Either + Music.Theory.Enum Music.Theory.Function + Music.Theory.Gamelan + Music.Theory.Graph.Deacon_1934 + Music.Theory.Graph.Dot + Music.Theory.Graph.FGL + Music.Theory.Graph.Johnson_2014 Music.Theory.Instrument.Choir + Music.Theory.Instrument.Names Music.Theory.Interval Music.Theory.Interval.Barlow_1987 Music.Theory.Interval.Name Music.Theory.Interval.Spelling + Music.Theory.IO Music.Theory.Key Music.Theory.List + Music.Theory.Map Music.Theory.Math + Music.Theory.Math.Convert + Music.Theory.Math.OEIS 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.Monad + Music.Theory.Ord + Music.Theory.Parse Music.Theory.Permutations Music.Theory.Permutations.List Music.Theory.Permutations.Morris_1984 Music.Theory.Pitch + Music.Theory.Pitch.Chord Music.Theory.Pitch.Name Music.Theory.Pitch.Note + Music.Theory.Pitch.Note.Name Music.Theory.Pitch.Spelling Music.Theory.Pitch.Spelling.Cluster + Music.Theory.Pitch.Spelling.Key + Music.Theory.Pitch.Spelling.Table + Music.Theory.Random.I_Ching + Music.Theory.Read Music.Theory.Set.List Music.Theory.Set.Set + Music.Theory.Show + Music.Theory.String Music.Theory.Tempo_Marking Music.Theory.Tiling.Canon Music.Theory.Tiling.Johnson_2004 @@ -89,26 +128,39 @@ Music.Theory.Time_Signature Music.Theory.Tuple Music.Theory.Tuning - Music.Theory.Tuning.Alves Music.Theory.Tuning.Alves_1997 + Music.Theory.Tuning.DB + Music.Theory.Tuning.DB.Alves + Music.Theory.Tuning.DB.Gann + Music.Theory.Tuning.DB.Microtonal_Synthesis + Music.Theory.Tuning.DB.Riley + Music.Theory.Tuning.DB.Werckmeister Music.Theory.Tuning.ET - Music.Theory.Tuning.Gann + Music.Theory.Tuning.Euler + Music.Theory.Tuning.Gann_1993 + Music.Theory.Tuning.Load 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.Rosenboom_1979 Music.Theory.Tuning.Scala + Music.Theory.Tuning.Scala.Interval + Music.Theory.Tuning.Scala.Mode + Music.Theory.Tuning.Sethares_1994 Music.Theory.Tuning.Syntonic - Music.Theory.Tuning.Werckmeister Music.Theory.Unicode + Music.Theory.Wyschnegradsky Music.Theory.Xenakis.S4 Music.Theory.Xenakis.Sieve Music.Theory.Z + Music.Theory.Z.Boros_1990 + Music.Theory.Z.Clough_1979 + Music.Theory.Z.Drape_1999 Music.Theory.Z.Forte_1973 Music.Theory.Z.Read_1978 + Music.Theory.Z.TTO Music.Theory.Z.SRO Music.Theory.Z12 Music.Theory.Z12.Castren_1994