diff --git a/Music/Theory/Array/CSV.hs b/Music/Theory/Array/CSV.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/CSV.hs @@ -0,0 +1,346 @@ +-- | Regular matrix array data, CSV, column & row indexing. +module Music.Theory.Array.CSV where + +import Data.Array {- array -} +import Data.Char {- base -} +import Data.Function {- base -} +import Data.List {- base -} +import Data.String {- base -} + +import qualified Text.CSV.Lazy.String as C {- lazy-csv -} + +import qualified Music.Theory.List as T {- hmt -} + +-- * Indexing + +-- | @A@ indexed case-insensitive column references. The column +-- following @Z@ is @AA@. +data Column_Ref = Column_Ref {column_ref_string :: String} + +instance IsString Column_Ref where fromString = Column_Ref +instance Read Column_Ref where readsPrec _ s = [(Column_Ref s,[])] +instance Show Column_Ref where show = column_ref_string +instance Eq Column_Ref where (==) = (==) `on` column_index +instance Ord Column_Ref where compare = compare `on` column_index + +instance Enum Column_Ref where + fromEnum = column_index + toEnum = column_ref + +instance Ix Column_Ref where + range = column_range + index = interior_column_index + inRange = column_in_range + rangeSize = column_range_size + +-- | Inclusive range of column references. +type Column_Range = (Column_Ref,Column_Ref) + +-- | @1@-indexed row reference. +type Row_Ref = Int + +-- | Zero index of 'Row_Ref'. +row_index :: Row_Ref -> Int +row_index r = r - 1 + +-- | Inclusive range of row references. +type Row_Range = (Row_Ref,Row_Ref) + +-- | Cell reference, column then row. +type Cell_Ref = (Column_Ref,Row_Ref) + +-- | Inclusive range of cell references. +type Cell_Range = (Cell_Ref,Cell_Ref) + +-- | Case folding letter to index function. Only valid for ASCII letters. +-- +-- > map letter_index ['A' .. 'Z'] == [0 .. 25] +-- > map letter_index ['a','d' .. 'm'] == [0,3 .. 12] +letter_index :: Char -> Int +letter_index c = fromEnum (toUpper c) - fromEnum 'A' + +-- | Inverse of 'letter_index'. +-- +-- > map index_letter [0,3 .. 12] == ['A','D' .. 'M'] +index_letter :: Int -> Char +index_letter i = toEnum (i + fromEnum 'A') + +-- | Translate column reference to @0@-index. +-- +-- > :set -XOverloadedStrings +-- > map column_index ["A","c","z","ac","XYZ"] == [0,2,25,28,17575] +column_index :: Column_Ref -> Int +column_index (Column_Ref c) = + let m = iterate (* 26) 1 + i = reverse (map letter_index c) + in sum (zipWith (*) m (zipWith (+) [0..] i)) + +-- | Column reference to interior index within specified range. Type +-- specialised 'Data.Ix.index'. +-- +-- > map (Data.Ix.index ('A','Z')) ['A','C','Z'] == [0,2,25] +-- > map (interior_column_index ("A","Z")) ["A","C","Z"] == [0,2,25] +-- +-- > map (Data.Ix.index ('B','C')) ['B','C'] == [0,1] +-- > map (interior_column_index ("B","C")) ["B","C"] == [0,1] +interior_column_index :: Column_Range -> Column_Ref -> Int +interior_column_index (l,r) c = + let n = column_index c + l' = column_index l + r' = column_index r + in if n > r' + then error (show ("interior_column_index",l,r,c)) + else n - l' + +-- | Inverse of 'column_index'. +-- +-- > let c = ["A","Z","AA","AZ","BA","BZ","CA"] +-- > in map column_ref [0,25,26,51,52,77,78] == c +-- +-- > column_ref (0+25+1+25+1+25+1) == "CA" +column_ref :: Int -> Column_Ref +column_ref = + let rec n = case n `quotRem` 26 of + (0,r) -> [index_letter r] + (q,r) -> index_letter (q - 1) : rec r + in Column_Ref . rec + +-- | Type specialised 'pred'. +-- +-- > column_ref_pred "DF" == "DE" +column_ref_pred :: Column_Ref -> Column_Ref +column_ref_pred = pred + +-- | Type specialised 'succ'. +-- +-- > column_ref_succ "DE" == "DF" +column_ref_succ :: Column_Ref -> Column_Ref +column_ref_succ = succ + +-- | Bimap of 'column_index'. +-- +-- > column_indices ("b","p") == (1,15) +-- > column_indices ("B","IT") == (1,253) +column_indices :: Column_Range -> (Int,Int) +column_indices = + let bimap f (i,j) = (f i,f j) + in bimap column_index + +-- | Type specialised 'Data.Ix.range'. +-- +-- > column_range ("L","R") == ["L","M","N","O","P","Q","R"] +-- > Data.Ix.range ('L','R') == "LMNOPQR" +column_range :: Column_Range -> [Column_Ref] +column_range rng = + let (l,r) = column_indices rng + in map column_ref [l .. r] + +-- | Type specialised 'Data.Ix.inRange'. +-- +-- > map (column_in_range ("L","R")) ["A","N","Z"] == [False,True,False] +-- > map (column_in_range ("L","R")) ["L","N","R"] == [True,True,True] +-- +-- > map (Data.Ix.inRange ('L','R')) ['A','N','Z'] == [False,True,False] +-- > map (Data.Ix.inRange ('L','R')) ['L','N','R'] == [True,True,True] +column_in_range :: Column_Range -> Column_Ref -> Bool +column_in_range rng c = + let (l,r) = column_indices rng + k = column_index c + in k >= l && k <= r + +-- | Type specialised 'Data.Ix.rangeSize'. +-- +-- > map column_range_size [("A","Z"),("AA","ZZ")] == [26,26 * 26] +-- > Data.Ix.rangeSize ('A','Z') == 26 +column_range_size :: Column_Range -> Int +column_range_size = (+ 1) . negate . uncurry (-) . column_indices + +-- | Type specialised 'Data.Ix.range'. +row_range :: Row_Range -> [Row_Ref] +row_range = range + +-- | The standard uppermost leftmost cell reference, @A1@. +-- +-- > Just cell_ref_minima == parse_cell_ref "A1" +cell_ref_minima :: Cell_Ref +cell_ref_minima = (Column_Ref "A",1) + +-- | Cell reference parser for standard notation of (column,row). +-- +-- > parse_cell_ref "CC348" == Just ("CC",348) +parse_cell_ref :: String -> Maybe Cell_Ref +parse_cell_ref s = + case span isUpper s of + ([],_) -> Nothing + (c,r) -> case span isDigit r of + (n,[]) -> Just (Column_Ref c,read n) + _ -> Nothing + +-- | Cell reference pretty printer. +-- +-- > cell_ref_pp ("CC",348) == "CC348" +cell_ref_pp :: Cell_Ref -> String +cell_ref_pp (Column_Ref c,r) = c ++ show r + +-- | Translate cell reference to @0@-indexed pair. +-- +-- > cell_index ("CC",348) == (80,347) +-- > Data.Ix.index (("AA",1),("ZZ",999)) ("CC",348) == 54293 +cell_index :: Cell_Ref -> (Int,Int) +cell_index (c,r) = (column_index c,row_index r) + +-- | Type specialised 'Data.Ix.range', cells are in column-order. +-- +-- > cell_range (("AA",1),("AC",1)) == [("AA",1),("AB",1),("AC",1)] +-- +-- > let r = [("AA",1),("AA",2),("AB",1),("AB",2),("AC",1),("AC",2)] +-- > in cell_range (("AA",1),("AC",2)) == r +-- +-- > Data.Ix.range (('A',1),('C',1)) == [('A',1),('B',1),('C',1)] +-- +-- > let r = [('A',1),('A',2),('B',1),('B',2),('C',1),('C',2)] +-- > in Data.Ix.range (('A',1),('C',2)) == r +cell_range :: Cell_Range -> [Cell_Ref] +cell_range ((c1,r1),(c2,r2)) = + [(c,r) | + c <- column_range (c1,c2) + ,r <- row_range (r1,r2)] + +-- | Variant of 'cell_range' in row-order. +-- +-- > let r = [(AA,1),(AB,1),(AC,1),(AA,2),(AB,2),(AC,2)] +-- > in cell_range_row_order (("AA",1),("AC",2)) == r +cell_range_row_order :: Cell_Range -> [Cell_Ref] +cell_range_row_order ((c1,r1),(c2,r2)) = + [(c,r) | + r <- row_range (r1,r2) + ,c <- column_range (c1,c2)] + +-- * TABLE + +-- | When reading a CSV file is the first row a header? +type CSV_Has_Header = Bool + +type CSV_Delimiter = Char + +type CSV_Allow_Linebreaks = Bool + +-- | When writing a CSV file should the delimiters be aligned, +-- ie. should columns be padded with spaces, and if so at which side +-- of the data? +data CSV_Align_Columns = CSV_No_Align | CSV_Align_Left | CSV_Align_Right + +-- | CSV options. +type CSV_Opt = (CSV_Has_Header,CSV_Delimiter,CSV_Allow_Linebreaks,CSV_Align_Columns) + +-- | Default CSV options, no header, comma delimiter, no linebreaks, no alignment. +def_csv_opt :: CSV_Opt +def_csv_opt = (False,',',False,CSV_No_Align) + +-- | Plain list representation of a two-dimensional table of /a/ in +-- row-order. Tables are regular, ie. all rows have equal numbers of +-- columns. +type Table a = [[a]] + +-- | CSV table, ie. a table with perhaps a header. +type CSV_Table a = (Maybe [String],Table a) + +-- | Read 'Table' from @CSV@ file. +csv_table_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (CSV_Table a) +csv_table_read (hdr,delim,brk,_) f fn = do + s <- readFile fn + let t = C.csvTable (C.parseDSV brk delim s) + p = C.fromCSVTable t + (h,d) = if hdr then (Just (head p),tail p) else (Nothing,p) + return (h,map (map f) d) + +-- | Read 'Table' only with 'def_csv_opt'. +csv_table_read' :: (String -> a) -> FilePath -> IO (Table a) +csv_table_read' f = fmap snd . csv_table_read def_csv_opt f + +-- | Read and process @CSV@ 'Table'. +csv_table_with :: CSV_Opt -> (String -> a) -> FilePath -> (CSV_Table a -> b) -> IO b +csv_table_with opt f fn g = fmap g (csv_table_read opt f fn) + +-- > csv_table_align CSV_No_Align [["a","row","and"],["then","another","one"]] +csv_table_align :: CSV_Align_Columns -> Table String -> Table String +csv_table_align align tbl = + let c = transpose tbl + n = map (maximum . map length) c + ext k s = let pd = replicate (k - length s) ' ' + in case align of + CSV_No_Align -> s + CSV_Align_Left -> pd ++ s + CSV_Align_Right -> s ++ pd + in transpose (zipWith (map . ext) n c) + +-- | Write 'Table' to @CSV@ file. +csv_table_write :: (a -> String) -> CSV_Opt -> FilePath -> CSV_Table a -> IO () +csv_table_write f (_,delim,brk,align) fn (hdr,tbl) = do + let tbl' = csv_table_align align (map (map f) tbl) + (_,t) = C.toCSVTable (T.mcons hdr tbl') + s = C.ppDSVTable brk delim t + writeFile fn s + +-- | Write 'Table' only (no header). +csv_table_write' :: (a -> String) -> CSV_Opt -> FilePath -> Table a -> IO () +csv_table_write' f opt fn tbl = csv_table_write f opt fn (Nothing,tbl) + +-- | @0@-indexed (row,column) cell lookup. +table_lookup :: Table a -> (Int,Int) -> a +table_lookup t (r,c) = (t !! r) !! c + +-- | Row data. +table_row :: Table a -> Row_Ref -> [a] +table_row t r = t !! row_index r + +-- | Column data. +table_column :: Table a -> Column_Ref -> [a] +table_column t c = transpose t !! column_index c + +-- | Lookup value across columns. +table_column_lookup :: Eq a => Table a -> (Column_Ref,Column_Ref) -> a -> Maybe a +table_column_lookup t (c1,c2) e = + let a = zip (table_column t c1) (table_column t c2) + in lookup e a + +-- | Table cell lookup. +table_cell :: Table a -> Cell_Ref -> a +table_cell t (c,r) = + let (r',c') = (row_index r,column_index c) + in table_lookup t (r',c') + +-- | @0@-indexed (row,column) cell lookup over column range. +table_lookup_row_segment :: Table a -> (Int,(Int,Int)) -> [a] +table_lookup_row_segment t (r,(c0,c1)) = + let r' = t !! r + in take (c1 - c0 + 1) (drop c0 r') + +-- | Range of cells from row. +table_row_segment :: Table a -> (Row_Ref,Column_Range) -> [a] +table_row_segment t (r,c) = + let (r',c') = (row_index r,column_indices c) + in table_lookup_row_segment t (r',c') + +-- * Array + +-- | Translate 'Table' to 'Array'. It is assumed that the 'Table' is +-- regular, ie. all rows have an equal number of columns. +-- +-- > let a = table_to_array [[0,1,3],[2,4,5]] +-- > in (bounds a,indices a,elems a) +-- +-- > > (((A,1),(C,2)) +-- > > ,[(A,1),(A,2),(B,1),(B,2),(C,1),(C,2)] +-- > > ,[0,2,1,4,3,5]) +table_to_array :: Table a -> Array Cell_Ref a +table_to_array t = + let nr = length t + nc = length (t !! 0) + bnd = (cell_ref_minima,(toEnum (nc - 1),nr)) + asc = zip (cell_range_row_order bnd) (concat t) + in array bnd asc + +-- | 'table_to_array' of 'csv_table_read'. +csv_array_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (Array Cell_Ref a) +csv_array_read opt f fn = fmap (table_to_array . snd) (csv_table_read opt f fn) diff --git a/Music/Theory/Array/CSV/Midi.hs b/Music/Theory/Array/CSV/Midi.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/CSV/Midi.hs @@ -0,0 +1,86 @@ +-- | 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/MD.hs b/Music/Theory/Array/MD.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/MD.hs @@ -0,0 +1,111 @@ +-- | Regular array data as markdown (MD) tables. +module Music.Theory.Array.MD where + +import Data.Char {- base -} +import Data.List {- base -} + +import qualified Music.Theory.List as T {- hmt -} + +-- | Append /k/ to the right of /l/ until result has /n/ places. +pad_right :: a -> Int -> [a] -> [a] +pad_right k n l = take n (l ++ repeat k) + +-- | Append /k/ to each row of /tbl/ as required to be regular (all +-- rows equal length). +make_regular :: a -> [[a]] -> [[a]] +make_regular k tbl = + let z = maximum (map length tbl) + in map (pad_right k z) tbl + +-- | Delete trailing 'Char' where 'isSpace' holds. +delete_trailing_whitespace :: [Char] -> [Char] +delete_trailing_whitespace = reverse . dropWhile isSpace . reverse + +-- | Optional header row then data rows. +type MD_Table t = (Maybe [String],[[t]]) + +-- | Join second table to right of initial table. +md_table_join :: MD_Table a -> MD_Table a -> MD_Table a +md_table_join (nm,c) (hdr,tbl) = + let hdr' = fmap (\h -> maybe h (++ h) nm) hdr + tbl' = map (\(i,r) -> i ++ r) (zip c tbl) + in (hdr',tbl') + +-- | Add a row number column at the front of the table. +md_number_rows :: MD_Table String -> MD_Table String +md_number_rows (hdr,tbl) = + let hdr' = fmap ("#" :) hdr + tbl' = map (\(i,r) -> show i : r) (zip [1::Int ..] tbl) + in (hdr',tbl') + +-- | Markdown table, perhaps with header. Table is in row order. +-- Options are: /pad_left/. +-- +-- > md_table_opt False (Nothing,[["a","bc","def"],["ghij","klm","no","p"]]) +md_table_opt :: Bool -> MD_Table String -> [String] +md_table_opt pleft (hdr,t) = + let t' = maybe t (:t) hdr + c = transpose (make_regular "" t') + n = map (maximum . map length) c + ext k s = let pd = replicate (k - length s) ' ' + in if pleft then pd ++ s else s ++ pd + m = unwords (map (flip replicate '-') n) + w = map unwords (transpose (zipWith (map . ext) n c)) + d = map delete_trailing_whitespace w + in case hdr of + Nothing -> T.bracket (m,m) d + Just _ -> case d of + [] -> error "md_table" + d0:d' -> d0 : T.bracket (m,m) d' + +md_table' :: MD_Table String -> [String] +md_table' = md_table_opt True + +-- | 'curry' of 'md_table''. +md_table :: Maybe [String] -> [[String]] -> [String] +md_table = curry md_table' + +-- | Variant relying on 'Show' instances. +-- +-- > md_table_show Nothing [[1..4],[5..8],[9..12]] +md_table_show :: Show t => Maybe [String] -> [[t]] -> [String] +md_table_show hdr = md_table hdr . map (map show) + +-- | Variant in column order (ie. 'transpose'). +-- +-- > md_table_column_order [["a","bc","def"],["ghij","klm","no"]] +md_table_column_order :: Maybe [String] -> [[String]] -> [String] +md_table_column_order hdr = md_table hdr . transpose + +-- | Two-tuple 'show' variant. +md_table_p2 :: (Show a,Show b) => Maybe [String] -> ([a],[b]) -> [String] +md_table_p2 hdr (p,q) = md_table hdr [map show p,map show q] + +-- | Three-tuple 'show' variant. +md_table_p3 :: (Show a,Show b,Show c) => Maybe [String] -> ([a],[b],[c]) -> [String] +md_table_p3 hdr (p,q,r) = md_table hdr [map show p,map show q,map show r] + +{- | Matrix form, ie. header in both first row and first column, in +each case displaced by one location which is empty. + +> let t = md_matrix "" (map return "abc") (map (map show) [[1,2,3],[2,3,1],[3,1,2]]) + +>>> putStrLn $ unlines $ md_table' t +- - - - + a b c +a 1 2 3 +b 2 3 1 +c 3 1 2 +- - - - + +-} +md_matrix :: a -> [a] -> [[a]] -> MD_Table a +md_matrix nil nm t = md_table_join (Nothing,[nil] : map return nm) (Nothing,nm : t) + +-- | Variant for 'String' tables where /nil/ is the empty string and +-- the header cells are in bold. +md_matrix_bold :: [String] -> [[String]] -> MD_Table String +md_matrix_bold nm t = + let bold x = "__" ++ x ++ "__" + nm' = map bold nm + in md_matrix "" nm' t 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 @@ -4,8 +4,9 @@ import Control.Arrow {- base -} import Data.List {- base -} -import qualified Music.Theory.List as L +import qualified Music.Theory.List as T + -- * Designs data Design i = Design [i] [[i]] @@ -22,8 +23,8 @@ b_7_3_1 = let c = c_7_3_1 f i (j1,j2) = sort [i,j1,j2] - in (zipWith f (L.rotate_left 3 c) (L.adj2_cyclic 1 c) - ,zipWith f c (L.adj2_cyclic 1 (L.rotate_left 2 c))) + in (zipWith f (T.rotate_left 3 c) (T.adj2_cyclic 1 c) + ,zipWith f c (T.adj2_cyclic 1 (T.rotate_left 2 c))) d_7_3_1 :: (Enum n,Ord n,Num n) => (Design n,Design n) d_7_3_1 = let d = Design [1..7] in (d *** d) b_7_3_1 @@ -41,12 +42,12 @@ b_13_4_1 :: (Enum i,Num i,Ord i) => ([[i]], [[i]]) b_13_4_1 = let c = [1..13] - c' = L.rotate_left 7 c - d = L.interleave_rotations 9 3 c - e = L.interleave_rotations 3 10 c + c' = T.rotate_left 7 c + d = T.interleave_rotations 9 3 c + e = T.interleave_rotations 3 10 c f (i1,i2) (j1,j2) = sort [i1,i2,j1,j2] - in (zipWith f (L.adj2 1 c) (L.adj2 2 d) - ,zipWith f (L.adj2 1 c') (L.adj2 2 e)) + in (zipWith f (T.adj2 1 c) (T.adj2 2 d) + ,zipWith f (T.adj2 1 c') (T.adj2 2 e)) d_13_4_1 :: (Enum n,Ord n,Num n) => (Design n,Design n) d_13_4_1 = let d = Design [1..13] in (d *** d) b_13_4_1 diff --git a/Music/Theory/Clef.hs b/Music/Theory/Clef.hs --- a/Music/Theory/Clef.hs +++ b/Music/Theory/Clef.hs @@ -9,9 +9,9 @@ deriving (Eq,Ord,Show) -- | Clef with octave offset. -data Integral i => Clef i = Clef {clef_t :: Clef_T - ,clef_octave :: i} - deriving (Eq,Ord,Show) +data Clef i = Clef {clef_t :: Clef_T + ,clef_octave :: i} + deriving (Eq,Ord,Show) -- | Give clef range as a 'Pitch' pair indicating the notes below and -- above the staff. @@ -42,3 +42,8 @@ clef_zero :: Integral i => Clef i -> Clef i clef_zero (Clef c_t _) = Clef c_t 0 +-- | Set 'clef_octave' to be no further than /r/ from @0@. +clef_restrict :: Integral i => i -> Clef i -> Clef i +clef_restrict r (Clef c_t n) = + let n' = if abs n > r then signum n * r else n + in Clef c_t n' 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 @@ -9,9 +9,10 @@ import qualified Data.Map as M {- containers -} import Data.Maybe {- base -} import Data.Ratio {- base -} -import qualified Music.Theory.Set.List as S -import qualified Music.Theory.Permutations.List as P +import qualified Music.Theory.Set.List as T +import qualified Music.Theory.Permutations.List as T + -- * List functions -- | Replace the /i/th value at /ns/ with /x/. @@ -198,8 +199,8 @@ all_contours n = let n' = contour_description_lm n ix = all_indices n - cs = filter (not.null) (S.powerset [LT,EQ,GT]) - pf = concatMap P.multiset_permutations . S.expand_set n' + cs = filter (not.null) (T.powerset [LT,EQ,GT]) + pf = concatMap T.multiset_permutations . T.expand_set n' mk p = Contour_Description n (M.fromList (zip ix p)) in map mk (concatMap pf cs) diff --git a/Music/Theory/Duration.hs b/Music/Theory/Duration.hs --- a/Music/Theory/Duration.hs +++ b/Music/Theory/Duration.hs @@ -1,10 +1,10 @@ -- | Common music notation duration model. module Music.Theory.Duration where -import Control.Monad -import Data.List -import Data.Maybe -import Data.Ratio +import Control.Monad {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} -- | Common music notation durational model data Duration = Duration {division :: Integer -- ^ division of whole note @@ -182,3 +182,20 @@ in case whole_note_division_pp x of Just x' -> Just (x' : d' ++ m') _ -> Nothing + +-- | Duration to @**recip@ notation. +-- +-- http://humdrum.org/Humdrum/representations/recip.rep.html +-- +-- > let d = map (\z -> Duration z 0 1) [0,1,2,4,8,16,32] +-- > in map duration_recip_pp d == ["0","1","2","4","8","16","32"] +-- +-- > let d = [Duration 1 1 (1/3),Duration 4 1 1,Duration 4 1 (2/3)] +-- > in map duration_recip_pp d == ["3.","4.","6."] +duration_recip_pp :: Duration -> String +duration_recip_pp (Duration x d m) = + let (mn,md) = (numerator m,denominator m) + r = (x % mn) * (md % 1) + in if denominator r == 1 + then show (numerator r) ++ genericReplicate d '.' + else error (show ("duration_recip_pp",x,d,m,r)) 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 @@ -1,11 +1,11 @@ -- | Duration annotations. module Music.Theory.Duration.Annotation where ---import Control.Applicative -import Data.Maybe -import Data.Ratio -import qualified Data.Traversable as T -import Data.Tree +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 @@ -37,7 +37,7 @@ Begin_Tuplet _ -> True _ -> False --- | Does 'Duration_A' being a tuplet? +-- | Does 'Duration_A' begin a tuplet? da_begins_tuplet :: Duration_A -> Bool da_begins_tuplet (_,a) = any begins_tuplet a diff --git a/Music/Theory/Duration/CT.hs b/Music/Theory/Duration/CT.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/CT.hs @@ -0,0 +1,195 @@ +-- | Functions to generate a click track from a metric structure. +module Music.Theory.Duration.CT where + +import Data.Function {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Duration.RQ as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Time_Signature as T {- hmt -} +import qualified Music.Theory.Time.Seq as T {- hmt -} + +-- | 1-indexed. +type Measure = Int + +-- | 1-indexed. +type Pulse = Int + +-- | Transform measures given as 'T.RQ' divisions to absolute 'T.RQ' +-- locations. /mdv/ abbreviates measure divisions. +-- +-- > mdv_to_mrq [[1,2,1],[3,2,1]] == [[0,1,3],[4,7,9]] +mdv_to_mrq :: [[T.RQ]] -> [[T.RQ]] +mdv_to_mrq = snd . mapAccumL T.dx_d' 0 + +-- | Lookup function for ('Measure','Pulse') indexed structure. +mp_lookup_err :: [[a]] -> (Measure,Pulse) -> a +mp_lookup_err sq (m,p) = + if m < 1 || p < 1 + then error (show ("mp_lookup_err: one indexed?",m,p)) + else (sq !! (m - 1)) !! (p - 1) + +-- | Comparison for ('Measure','Pulse') indices. +mp_compare :: (Measure,Pulse) -> (Measure,Pulse) -> Ordering +mp_compare = T.two_stage_compare (compare `on` fst) (compare `on` snd) + +-- * CT + +-- | Latch measures (ie. make measures contiguous, hold previous value). +-- +-- > unzip (ct_ext 10 'a' [(3,'b'),(8,'c')]) == ([1..10],"aabbbbbccc") +ct_ext :: Int -> a -> [(Measure,a)] -> [(Measure,a)] +ct_ext n def sq = T.tseq_latch def sq [1 .. n] + +-- | Variant that requires a value at measure one (first measure). +ct_ext1 :: Int -> [(Measure,a)] -> [(Measure,a)] +ct_ext1 n sq = + case sq of + (1,e) : sq' -> ct_ext n e sq' + _ -> error "ct_ext1" + +-- | 'T.rts_divisions' of 'ct_ext1'. +ct_dv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [(Measure,[[T.RQ]])] +ct_dv_seq n ts = map (fmap T.rts_divisions) (ct_ext1 n ts) + +-- | 'ct_dv_seq' without measures numbers. +ct_mdv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.RQ]] +ct_mdv_seq n = map (concat . snd) . ct_dv_seq n + +-- | 'mdv_to_mrq' of 'ct_mdv_seq'. +ct_rq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.RQ]] +ct_rq n ts = mdv_to_mrq (ct_mdv_seq n ts) + +ct_mp_lookup :: [[T.RQ]] -> (Measure,Pulse) -> T.RQ +ct_mp_lookup = mp_lookup_err . mdv_to_mrq + +ct_m_to_rq :: [[T.RQ]] -> [(Measure,t)] -> [(T.RQ,t)] +ct_m_to_rq sq = map (\(m,c) -> (ct_mp_lookup sq (m,1),c)) + +-- | Latch rehearsal mark sequence, only indicating marks. Initial mark is @.@. +-- +-- > ct_mark_seq 2 [] == [(1,Just '.'),(2,Nothing)] +-- +-- > let r = [(1,Just '.'),(3,Just 'A'),(8,Just 'B')] +-- > in filter (isJust . snd) (ct_mark_seq 10 [(3,'A'),(8,'B')]) == r +ct_mark_seq :: Int -> T.Tseq Measure Char -> T.Tseq Measure (Maybe Char) +ct_mark_seq n mk = T.seq_changed (ct_ext n '.' mk) + +-- | Indicate measures prior to marks. +-- +-- > ct_pre_mark [] == [] +-- > ct_pre_mark [(1,'A')] == [] +-- > ct_pre_mark [(3,'A'),(8,'B')] == [(2,Just ()),(7,Just ())] +ct_pre_mark :: [(Measure,a)] -> [(Measure,Maybe ())] +ct_pre_mark = mapMaybe (\(m,_) -> if m <= 1 then Nothing else Just (m - 1,Just ())) + +-- | Contiguous pre-mark sequence. +-- +-- > ct_pre_mark_seq 1 [(1,'A')] == [(1,Nothing)] +-- > ct_pre_mark_seq 10 [(3,'A'),(8,'B')] +ct_pre_mark_seq :: Measure -> T.Tseq Measure Char -> T.Tseq Measure (Maybe ()) +ct_pre_mark_seq n mk = + let pre = ct_pre_mark mk + in T.tseq_merge_resolve const pre (zip [1 .. n] (repeat Nothing)) + +ct_tempo_lseq_rq :: [[T.RQ]] -> T.Lseq (Measure,Pulse) T.RQ -> T.Lseq T.RQ T.RQ +ct_tempo_lseq_rq sq = T.lseq_tmap (ct_mp_lookup sq) + +-- | Interpolating lookup of tempo sequence ('T.lseq_lookup_err'). +ct_tempo_at :: T.Lseq T.RQ T.RQ -> T.RQ -> Rational +ct_tempo_at = T.lseq_lookup_err compare + +-- | Types of nodes. +data CT_Node = CT_Mark T.RQ -- ^ The start of a measure with a rehearsal mark. + | CT_Start T.RQ -- ^ The start of a regular measure. + | CT_Normal T.RQ -- ^ A regular pulse. + | CT_Edge T.RQ -- ^ The start of a pulse group within a measure. + | CT_Pre T.RQ -- ^ A regular pulse in a measure prior to a rehearsal mark. + | CT_End -- ^ The end of the track. + deriving (Eq,Show) + +-- | Lead-in of @(pulse,tempo,count)@. +ct_leadin :: (T.RQ,Double,Int) -> T.Dseq Double CT_Node +ct_leadin (du,tm,n) = replicate n (realToFrac du * (60 / tm),CT_Normal du) + +-- | Prepend initial element to start of list. +-- +-- > delay1 "abc" == "aabc" +delay1 :: [a] -> [a] +delay1 l = + case l of + [] -> error "delay1: []" + e:_ -> e : l + +ct_measure:: T.Lseq T.RQ T.RQ -> ([T.RQ],Maybe Char,Maybe (),[[T.RQ]]) -> [(Rational,CT_Node)] +ct_measure sq (mrq,mk,pr,dv) = + let dv' = concatMap (zip [1..]) dv + f (p,rq,(g,du)) = + let nm = if p == 1 + then case mk of + Nothing -> CT_Start du + Just _ -> CT_Mark du + else if pr == Just () + then CT_Pre du + else if g == 1 then CT_Edge du else CT_Normal du + in (du * (60 / ct_tempo_at sq rq),nm) + in map f (zip3 [1..] mrq dv') + +-- | Click track definition. +data CT = CT {ct_len :: Int + ,ct_ts :: [(Measure,T.Rational_Time_Signature)] + ,ct_mark :: [(Measure,Char)] + ,ct_tempo :: T.Lseq (Measure,Pulse) T.RQ + ,ct_count :: (T.RQ,Int)} + deriving Show + +-- | Initial tempo, if given. +ct_tempo0 :: CT -> Maybe T.RQ +ct_tempo0 ct = + case ct_tempo ct of + (((1,1),_),n):_ -> Just n + _ -> Nothing + +-- | Erroring variant. +ct_tempo0_err :: CT -> T.RQ +ct_tempo0_err = fromMaybe (error "ct_tempo0") . ct_tempo0 + +-- > import Music.Theory.Duration.CT +-- > import Music.Theory.Time.Seq +-- > let ct = CT 2 [(1,[(3,8),(2,4)])] [(1,'a')] [(((1,0),T.None),60)] undefined +-- > ct_measures ct +ct_measures :: CT -> [T.Dseq Rational CT_Node] +ct_measures (CT n ts mk tm _) = + let f msg sq = let (m,v) = unzip sq + in if m == [1 .. n] + then v + else error (show ("ct_measures",msg,sq,m,v,n)) + msr = zip4 + (f "ts" (zip [1..] (ct_rq n ts))) + (f "mk" (ct_mark_seq n mk)) + (f "pre-mk" (ct_pre_mark_seq n mk)) + (f "dv" (ct_dv_seq n ts)) + in map (ct_measure (ct_tempo_lseq_rq (ct_mdv_seq n ts) tm)) msr + +ct_dseq' :: CT -> T.Dseq Rational CT_Node +ct_dseq' = concat . ct_measures + +ct_dseq :: CT -> T.Dseq Double CT_Node +ct_dseq = T.dseq_tmap fromRational . ct_dseq' + +-- * Indirect + +ct_rq_measure :: [[T.RQ]] -> T.RQ -> Maybe Measure +ct_rq_measure sq rq = fmap fst (find ((rq `elem`) . snd) (zip [1..] sq)) + +ct_rq_mp :: [[T.RQ]] -> T.RQ -> Maybe (Measure,Pulse) +ct_rq_mp sq rq = + let f (m,l) = (m,fromMaybe (error "ct_rq_mp: ix") (findIndex (== rq) l) + 1) + in fmap f (find ((rq `elem`) . snd) (zip [1..] sq)) + +ct_rq_mp_err :: [[T.RQ]] -> T.RQ -> (Measure, Pulse) +ct_rq_mp_err sq = fromMaybe (error "ct_rq_mp") . ct_rq_mp sq + +ct_mp_to_rq :: [[T.RQ]] -> [((Measure,Pulse),t)] -> [(T.RQ,t)] +ct_mp_to_rq sq = map (\(mp,c) -> (ct_mp_lookup sq mp,c)) 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 @@ -1,10 +1,11 @@ -- | Rational quarter-note notation for durations. module Music.Theory.Duration.RQ where -import Data.Function -import Data.List -import Data.Maybe -import Data.Ratio +import Data.Function {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} + import Music.Theory.Duration import Music.Theory.Duration.Name @@ -38,7 +39,7 @@ -- | Is 'RQ' a /cmn/ duration. -- --- > map rq_is_cmn [1/4,1/5,1/8] == [True,False,True] +-- > map rq_is_cmn [1/4,1/5,1/8,3/32] == [True,False,True,False] rq_is_cmn :: RQ -> Bool rq_is_cmn = isJust . rq_to_duration @@ -70,7 +71,8 @@ -- | Convert 'Duration' to 'RQ' value, see 'rq_to_duration' for -- partial inverse. -- --- > map duration_to_rq [half_note,dotted_quarter_note] == [2,3/2] +-- > let d = [half_note,dotted_quarter_note,dotted_whole_note] +-- > in map duration_to_rq d == [2,3/2,6] duration_to_rq :: Duration -> RQ duration_to_rq (Duration n d m) = let x = whole_note_division_to_rq n @@ -176,6 +178,7 @@ -- > rq_can_notate [2/5,1/10] == True -- > rq_can_notate [1/3,1/6,2/5,1/10] == False -- > rq_can_notate [4/7,1/7,6/7,3/7] == True +-- > rq_can_notate [4/7,1/7,2/7] == True rq_can_notate :: [RQ] -> Bool rq_can_notate x = let x' = case rq_derive_tuplet x of 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,18 +17,21 @@ -- 5. Ascribe values to notated durations, see 'ascribe'. module Music.Theory.Duration.Sequence.Notate where -import Control.Applicative -import Control.Monad -import Data.List +import Control.Applicative {- base -} +import Control.Monad {- base -} +import Data.List {- base -} import Data.List.Split {- split -} -import Data.Ratio -import Music.Theory.Duration -import Music.Theory.Duration.Annotation -import Music.Theory.Duration.RQ -import Music.Theory.Duration.RQ.Tied -import Music.Theory.List -import Music.Theory.Time_Signature +import Data.Maybe {- base -} +import Data.Ratio {- base -} +import Music.Theory.Duration {- hmt -} +import Music.Theory.Duration.Annotation {- hmt -} +import Music.Theory.Function {- hmt -} +import Music.Theory.Duration.RQ {- hmt -} +import Music.Theory.Duration.RQ.Tied {- hmt -} +import Music.Theory.List {- hmt -} +import Music.Theory.Time_Signature {- hmt -} + -- * Lists -- | Variant of 'catMaybes'. If all elements of the list are @Just @@ -160,7 +163,7 @@ -- | Split sequence such that the prefix sums to precisely /m/. The -- third element of the result indicates if it was required to divide --- an element. Not that zero elements are kept left. If the required +-- an element. Note that zero elements are kept left. If the required -- sum is non positive, or the input list does not sum to at least the -- required sum, gives nothing. -- @@ -199,6 +202,8 @@ -- -- > let r = Just ([(3,_f),(1,_t)],[(1,_t),(1,_f)]) -- > in rqt_split_sum 4 [(3,_f),(2,_t),(1,_f)] == r +-- +-- > rqt_split_sum 4 [(5/2,False)] == Nothing rqt_split_sum :: RQ -> [RQ_T] -> Maybe ([RQ_T],[RQ_T]) rqt_split_sum d x = case split_sum d (map rqt_rq x) of @@ -216,11 +221,11 @@ -- -- > let d = [(2,_f),(2,_f),(2,_f)] -- > in rqt_separate [3,3] d == Right [[(2,_f),(1,_t)] --- > ,[(1,_f),(2,_f)]] +-- > ,[(1,_f),(2,_f)]] -- -- > let d = [(5/8,_f),(1,_f),(3/8,_f)] -- > in rqt_separate [1,1] d == Right [[(5/8,_f),(3/8,_t)] --- > ,[(5/8,_f),(3/8,_f)]] +-- > ,[(5/8,_f),(3/8,_f)]] -- -- > let d = [(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)] -- > in rqt_separate [1,1,1] d == Right [[(4/7,_t),(1/7,_f),(2/7,_t)] @@ -261,7 +266,7 @@ rqt_separate_tuplet :: RQ -> [RQ_T] -> Either String [[RQ_T]] rqt_separate_tuplet i x = if rqt_can_notate x - then Left (show ("rqt_separate_tuplet: cannot notate",x)) + then Left (show ("rqt_separate_tuplet: separation not required",x)) else let j = sum (map rqt_rq x) / 2 in if j < i then Left (show ("rqt_separate_tuplet: j < i",j,i)) @@ -395,34 +400,44 @@ m_divisions_ts :: Time_Signature -> [RQ_T] -> Either String [[RQ_T]] m_divisions_ts ts = m_divisions_rq (ts_divisions ts) --- | Composition of 'to_measures_rq' and 'm_divisions_rq', where --- measures are initially given as sets of divisions. --- --- > let m = [[1,1,1],[1,1,1]] --- > in to_divisions_rq m [2,2,2] == Just [[[(1,_t)],[(1,_f)],[(1,_t)]] --- > ,[[(1,_f)],[(1,_t)],[(1,_f)]]] --- --- > let d = [2/7,1/7,4/7,5/7,8/7,1,1/7] --- > in to_divisions_rq [[1,1,1,1]] d == Just [[[(2/7,_f),(1/7,_f),(4/7,_f)] --- > ,[(4/7,_t),(1/7,_f),(2/7,_t)] --- > ,[(6/7,_f),(1/7,_t)] --- > ,[(6/7,_f),(1/7,_f)]]] --- --- > let d = [5/7,1,6/7,3/7] --- > in to_divisions_rq [[1,1,1]] d == Just [[[(4/7,_t),(1/7,_f),(2/7,_t)] --- > ,[(4/7,_t),(1/7,_f),(2/7,_t)] --- > ,[(4/7,_f),(3/7,_f)]]] --- --- > let d = [2/7,1/7,4/7,5/7,1,6/7,3/7] --- > in to_divisions_rq [[1,1,1,1]] d == Just [[[(2/7,_f),(1/7,_f),(4/7,_f)] --- > ,[(4/7,_t),(1/7,_f),(2/7,_t)] --- > ,[(4/7,_t),(1/7,_f),(2/7,_t)] --- > ,[(4/7,_f),(3/7,_f)]]] --- --- > let d = [4/7,33/28,9/20,4/5] --- > in to_divisions_rq [[1,1,1]] d == Just [[[(4/7,_f),(3/7,_t)] --- > ,[(3/4,_f),(1/4,_t)] --- > ,[(1/5,_f),(4/5,_f)]]] +{-| Composition of 'to_measures_rq' and 'm_divisions_rq', where +measures are initially given as sets of divisions. + +> let m = [[1,1,1],[1,1,1]] +> in to_divisions_rq m [2,2,2] == Right [[[(1,_t)],[(1,_f)],[(1,_t)]] +> ,[[(1,_f)],[(1,_t)],[(1,_f)]]] + +> let d = [2/7,1/7,4/7,5/7,8/7,1,1/7] +> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,_f),(1/7,_f),(4/7,_f)] +> ,[(4/7,_t),(1/7,_f),(2/7,_t)] +> ,[(6/7,_f),(1/7,_t)] +> ,[(6/7,_f),(1/7,_f)]]] + +> let d = [5/7,1,6/7,3/7] +> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,_t),(1/7,_f),(2/7,_t)] +> ,[(4/7,_t),(1/7,_f),(2/7,_t)] +> ,[(4/7,_f),(3/7,_f)]]] + +> let d = [2/7,1/7,4/7,5/7,1,6/7,3/7] +> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,_f),(1/7,_f),(4/7,_f)] +> ,[(4/7,_t),(1/7,_f),(2/7,_t)] +> ,[(4/7,_t),(1/7,_f),(2/7,_t)] +> ,[(4/7,_f),(3/7,_f)]]] + +> let d = [4/7,33/28,9/20,4/5] +> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,_f),(3/7,_t)] +> ,[(3/4,_f),(1/4,_t)] +> ,[(1/5,_f),(4/5,_f)]]] + +> let {p = [[1/2,1,1/2],[1/2,1]] +> ;d = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]} +> in to_divisions_rq p d == Right [[[(1/6,_f),(1/6,_f),(1/6,_f)] +> ,[(1/6,_f),(1/6,_f),(1/6,_f),(1/2,True)] +> ,[(1/6,_f),(1/6,_f),(1/6,True)]] +> ,[[(1/6,_f),(1/6,_f),(1/6,_f)] +> ,[(1/3,_f),(1/6,_f),(1/2,_f)]]] + +-} to_divisions_rq :: [[RQ]] -> [RQ] -> Either String [[[RQ_T]]] to_divisions_rq m x = let m' = map sum m @@ -486,7 +501,9 @@ d = case p_tuplet_rqt x of Just (t,x') -> da_tuplet t (f x') Nothing -> f x - in if rq_can_notate (map rqt_rq x) then Right d else Left (show ("p_notate",z,x)) + in if rq_can_notate (map rqt_rq x) + then Right d + else Left (show ("p_notate",z,x)) -- | Notate measure. -- @@ -501,16 +518,22 @@ let z' = z : map (is_tied_right . last) m in fmap concat (all_right (zipWith p_notate z' m)) --- | Multiple measure notation. --- --- > let d = [2/7,1/7,4/7,5/7,8/7,1,1/7] --- > in fmap mm_notate (to_divisions_ts [(4,4)] d) --- --- > let d = [2/7,1/7,4/7,5/7,1,6/7,3/7] --- > in fmap mm_notate (to_divisions_ts [(4,4)] d) --- --- > let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2] --- > in fmap mm_notate (to_divisions_ts [(4,4)] d) +{-| Multiple measure notation. + +> let d = [2/7,1/7,4/7,5/7,8/7,1,1/7] +> in fmap mm_notate (to_divisions_ts [(4,4)] d) + +> let d = [2/7,1/7,4/7,5/7,1,6/7,3/7] +> in fmap mm_notate (to_divisions_ts [(4,4)] d) + +> let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2] +> in fmap mm_notate (to_divisions_ts [(4,4)] d) + +> let {p = [[1/2,1,1/2],[1/2,1]] +> ;d = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]} +> in fmap mm_notate (to_divisions_rq p d) + +-} mm_notate :: [[[RQ_T]]] -> Either String [[Duration_A]] mm_notate d = let z = False : map (is_tied_right . last . last) d @@ -610,7 +633,7 @@ m_simplify p ts = let f st (d0,a0) (d1,a1) = let t = Tie_Right `elem` a0 && Tie_Left `elem` a1 - e = End_Tuplet `notElem` a0 || any begins_tuplet a1 + e = End_Tuplet `notElem` a0 && not (any begins_tuplet a1) m = duration_meq d0 d1 d = sum_dur d0 d1 a = delete Tie_Right a0 ++ delete Tie_Left a1 @@ -643,13 +666,32 @@ -- * Notate --- | Composition of 'to_divisions_ts', 'mm_notate' 'm_simplify'. -notate :: Simplify_P -> [Time_Signature] -> [RQ] -> Either String [[Duration_A]] -notate r ts x = do - mm <- to_divisions_ts ts x - dd <- mm_notate mm - return (zipWith (m_simplify r) ts dd) +{-| Notate RQ duration sequence. Derive pulse divisions from +'Time_Signature' if not given directly. Composition of +'to_divisions_ts', 'mm_notate' 'm_simplify'. +> let ts = [(4,8),(3,8)] +> ts_p = [[1/2,1,1/2],[1/2,1]] +> rq = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3] +> sr x = T.default_rule [] x +> in T.notate_rqp sr ts (Just ts_p) rq + +-} +notate_rqp :: Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> + Either String [[Duration_A]] +notate_rqp r ts ts_p x = do + let ts_p' = fromMaybe (map ts_divisions ts) ts_p + mm <- to_divisions_rq ts_p' x + dd <- mm_notate mm + return (zipWith (m_simplify r) ts dd) + +-- | Variant of 'notate_rqp' without pulse divisions (derive). +-- +-- > notate (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6] +notate :: Simplify_P -> [Time_Signature] -> [RQ] -> + Either String [[Duration_A]] +notate r ts x = notate_rqp r ts Nothing x + -- * Ascribe -- | Variant of 'zip' that retains elements of the right hand (rhs) @@ -662,13 +704,13 @@ -- > zip_hold_lhs odd [1..6] "abc" == ([],zip [1..6] "aabbcc") -- > zip_hold_lhs even [1] "ab" == ("b",[(1,'a')]) -- > zip_hold_lhs even [1,2] "a" == undefined -zip_hold_lhs :: (x -> Bool) -> [x] -> [t] -> ([t],[(x,t)]) +zip_hold_lhs :: (Show t,Show x) => (x -> Bool) -> [x] -> [t] -> ([t],[(x,t)]) zip_hold_lhs lhs_f = let f st e = case st of r:s -> let st' = if lhs_f e then st else s in (st',(e,r)) - _ -> error "zip_hold_lhs: rhs ends" + _ -> error (show ("zip_hold_lhs: rhs ends",st,e)) in flip (mapAccumL f) -- | Variant of 'zip_hold' that requires the right hand side to be @@ -678,15 +720,15 @@ -- > zip_hold_lhs_err odd [1..6] "abc" == zip [1..6] "aabbcc" -- > zip_hold_lhs_err id [False,False] "a" == undefined -- > zip_hold_lhs_err id [False] "ab" == undefined -zip_hold_lhs_err :: (x -> Bool) -> [x] -> [a] -> [(x,a)] +zip_hold_lhs_err :: (Show t,Show x) => (x -> Bool) -> [x] -> [t] -> [(x,t)] zip_hold_lhs_err lhs_f p q = case zip_hold_lhs lhs_f p q of ([],r) -> r - _ -> error "zip_hold_lhs_err: lhs ends" + e -> error (show ("zip_hold_lhs_err: lhs ends",e)) -- | Variant of 'zip' that retains elements of the right hand (rhs) -- list where elements of the left hand (lhs) list meet the given lhs --- predicate, and elements of the lhs list where elements of the ths +-- predicate, and elements of the lhs list where elements of the rhs -- meet the rhs predicate. If the right hand side is longer the -- remaining elements to be processed are given. It is an error for -- the right hand side to be short. @@ -697,7 +739,7 @@ -- > zip_hold even (const False) [1,2] "a" == undefined -- -- > zip_hold odd even [1,2,6] [1..5] == ([4,5],[(1,1),(2,1),(6,2),(6,3)]) -zip_hold :: (x -> Bool) -> (t -> Bool) -> [x] -> [t] -> ([t],[(x,t)]) +zip_hold :: (Show t,Show x) => (x -> Bool) -> (t -> Bool) -> [x] -> [t] -> ([t],[(x,t)]) zip_hold lhs_f rhs_f = let f r x t = case (x,t) of @@ -714,22 +756,35 @@ -- > let {Just d = to_divisions_ts [(4,4),(4,4)] [3,3,2] -- > ;f = map snd . snd . flip m_ascribe "xyz"} -- > in fmap f (notate d) == Just "xxxyyyzz" -m_ascribe :: [Duration_A] -> [x] -> ([x],[(Duration_A,x)]) +m_ascribe :: Show x => [Duration_A] -> [x] -> ([x],[(Duration_A,x)]) m_ascribe = zip_hold_lhs da_tied_right -- | 'snd' '.' 'm_ascribe'. -ascribe :: [Duration_A] -> [x] -> [(Duration_A, x)] +ascribe :: Show x => [Duration_A] -> [x] -> [(Duration_A, x)] ascribe d = snd . m_ascribe d -- | Variant of 'm_ascribe' for a set of measures. -mm_ascribe :: [[Duration_A]] -> [x] -> [[(Duration_A,x)]] +mm_ascribe :: Show x => [[Duration_A]] -> [x] -> [[(Duration_A,x)]] mm_ascribe mm x = case mm of [] -> [] m:mm' -> let (x',r) = m_ascribe m x in r : mm_ascribe mm' x' --- | Group elements as /chords/ where a chord element is inidicated by +-- | 'mm_ascribe of 'notate'. +notate_mm_ascribe :: Show a => [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] -> + Either String [[(Duration_A,a)]] +notate_mm_ascribe r ts rqp d p = + let n = notate_rqp (default_rule r) ts rqp d + f = flip mm_ascribe p + err str = show ("notate_ascribe",str,ts,d,p) + in either (Left . err) (Right . f) n + +notate_mm_ascribe_err :: Show a => [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] -> + [[(Duration_A,a)]] +notate_mm_ascribe_err = either error id .:::: notate_mm_ascribe + +-- | Group elements as /chords/ where a chord element is indicated by -- the given predicate. -- -- > group_chd even [1,2,3,4,4,5,7,8] == [[1,2],[3,4,4],[5],[7,8]] @@ -742,14 +797,14 @@ -- | Variant of 'ascribe' that groups the /rhs/ elements using -- 'group_chd' and with the indicated /chord/ function, then rejoins -- the resulting sequence. -ascribe_chd :: (x -> Bool) -> [Duration_A] -> [x] -> [(Duration_A, x)] +ascribe_chd :: Show x => (x -> Bool) -> [Duration_A] -> [x] -> [(Duration_A, x)] ascribe_chd chd_f d x = let x' = group_chd chd_f x jn (i,j) = zip (repeat i) j in concatMap jn (ascribe d x') -- | Variant of 'mm_ascribe' using 'group_chd' -mm_ascribe_chd :: (x -> Bool) -> [[Duration_A]] -> [x] -> [[(Duration_A,x)]] +mm_ascribe_chd :: Show x => (x -> Bool) -> [[Duration_A]] -> [x] -> [[(Duration_A,x)]] mm_ascribe_chd chd_f d x = let x' = group_chd chd_f x jn (i,j) = zip (repeat i) j 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 @@ -1,10 +1,12 @@ -- | Common music notation dynamic marks. module Music.Theory.Dynamic_Mark where -import Data.List -import Data.Maybe -import Music.Theory.List +import Data.Char {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import qualified Music.Theory.List as T + -- | Enumeration of dynamic mark symbols. data Dynamic_Mark_T = Niente | PPPPP | PPPP | PPP | PP | P | MP @@ -17,11 +19,25 @@ -- -- > let r = [0,6,17,28,39,50,61,72,83,94,105,116,127] -- > in mapMaybe dynamic_mark_midi [Niente .. FFFFF] == r +-- +-- > map dynamic_mark_midi [FP,SF,SFP,SFPP,SFZ,SFFZ] == replicate 6 Nothing dynamic_mark_midi :: (Num n,Enum n) => Dynamic_Mark_T -> Maybe n dynamic_mark_midi m = let r = zip [0..] (0 : reverse [127, 127-11 .. 0]) in lookup (fromEnum m) r +-- | Error variant. +dynamic_mark_midi_err :: Integral n => Dynamic_Mark_T -> n +dynamic_mark_midi_err = fromMaybe (error "dynamic_mark_midi") . dynamic_mark_midi + +-- | Map midi velocity (0-127) to dynamic mark. +-- +-- > histogram (mapMaybe midi_dynamic_mark [0 .. 127]) +midi_dynamic_mark :: (Ord n,Eq n,Num n,Enum n) => n -> Maybe Dynamic_Mark_T +midi_dynamic_mark m = + let r = zip (0 : [12,24 .. 132]) [0..] + in fmap (toEnum . snd) (find ((>= m) . fst) r) + -- | Translate /fixed/ 'Dynamic_Mark_T's to /db/ amplitude over given -- /range/. -- @@ -35,6 +51,29 @@ f i = negate r + (fromIntegral i * k) in fmap f (elemIndex m u) +-- | +-- +-- > import Sound.SC3.Plot +-- > plotTable [map (ampmidid 20) [0 .. 127],map (ampmidid 60) [0 .. 127]] +ampmidid :: Floating a => a -> a -> a +ampmidid db v = + let r = 10 ** (db / 20) + b = 127 / (126 * sqrt r) - 1 / 126 + m = (1 - b) / 127 + in (m * v + b) ** 2 + +-- | JMcC (SC3) equation. +-- +-- > plotTable1 (map amp_db [0,0.005 .. 1]) +amp_db :: Floating a => a -> a +amp_db a = logBase 10 a * 20 + +-- | JMcC (SC3) equation. +-- +-- > plotTable1 (map db_amp [-60,-59 .. 0]) +db_amp :: Floating a => a -> a +db_amp a = 10 ** (a * 0.05) + -- | Enumeration of hairpin indicators. data Hairpin_T = Crescendo | Diminuendo | End_Hairpin deriving (Eq,Ord,Enum,Bounded,Show) @@ -76,7 +115,7 @@ then (j,e) : rec False p' else (j,k) : rec False p' Just _ -> (j,k) : rec True p' - in rec False (zip (indicate_repetitions d) h) + in rec False (zip (T.indicate_repetitions d) h) -- | Delete redundant (unaltered) dynamic marks. -- @@ -104,7 +143,7 @@ let f l = case l of Nothing:_ -> map (const Nothing) l _ -> map Just (dynamic_sequence (catMaybes l)) - in concatMap f . group_just . delete_redundant_marks + in concatMap f . T.group_just . delete_redundant_marks -- | Apply 'Hairpin_T' and 'Dynamic_Mark_T' functions in that order as -- required by 'Dynamic_Node'. @@ -117,4 +156,34 @@ let n = maybe m (g m) j in maybe n (f n) i +-- * ASCII +-- | ASCII pretty printer for 'Dynamic_Mark_T'. +dynamic_mark_ascii :: Dynamic_Mark_T -> String +dynamic_mark_ascii = map toLower . show + +-- | ASCII pretty printer for 'Hairpin_T'. +hairpin_ascii :: Hairpin_T -> String +hairpin_ascii hp = + case hp of + Crescendo -> "<" + Diminuendo -> ">" + End_Hairpin -> "" + +-- | ASCII pretty printer for 'Dynamic_Node'. +dynamic_node_ascii :: Dynamic_Node -> String +dynamic_node_ascii (mk,hp) = + let mk' = maybe "" dynamic_mark_ascii mk + hp' = maybe "" hairpin_ascii hp + in case (mk',hp') of + ([],[]) -> [] + ([],_) -> hp' + (_,[]) -> mk' + _ -> mk' ++ " " ++ hp' + +-- | ASCII pretty printer for 'Dynamic_Node' sequence. +dynamic_sequence_ascii :: [Dynamic_Node] -> String +dynamic_sequence_ascii = + intercalate " " . + filter (not . null) . + map dynamic_node_ascii diff --git a/Music/Theory/Either.hs b/Music/Theory/Either.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Either.hs @@ -0,0 +1,16 @@ +-- | Either +module Music.Theory.Either where + +-- | Maybe 'Left' of 'Either'. +fromLeft :: Either a b -> Maybe a +fromLeft e = + case e of + Left x -> Just x + _ -> Nothing + +-- | Maybe 'Right' of 'Either'. +fromRight :: Either a b -> Maybe b +fromRight e = + case e of + Right x -> Just x + _ -> Nothing diff --git a/Music/Theory/Function.hs b/Music/Theory/Function.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Function.hs @@ -0,0 +1,52 @@ +-- | "Data.Function" related functions. +module Music.Theory.Function where + +-- * Predicate composition. + +-- | '&&' of predicates. +predicate_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool +predicate_and f g x = f x && g x + +-- | 'all' of predicates. +-- +-- > let r = [False,False,True,False,True,False] +-- > in map (predicate_all [(> 0),(< 5),even]) [0..5] == r +predicate_all :: [t -> Bool] -> t -> Bool +predicate_all p x = all id (map ($ x) p) + +-- | '||' of predicates. +predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool +predicate_or f g x = f x || g x + +-- | 'any' of predicates. +-- +-- > let r = [True,False,True,False,True,True] +-- > in map (predicate_any [(== 0),(== 5),even]) [0..5] == r +predicate_any :: [t -> Bool] -> t -> Bool +predicate_any p x = any id (map ($ x) p) + +-- * Function composition. + +-- . is infixr 9, this allows f . g .: h +infixr 8 .:, .::, .:::, .::::, .::::: + +-- | 'fmap' '.' 'fmap', ie. @(t -> c) -> (a -> b -> t) -> a -> b -> c@. +(.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(.:) = fmap . fmap + +-- | 'fmap' '.' '.:', ie. @(t -> d) -> (a -> b -> c -> t) -> a -> b -> c -> d@. +(.::) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b)) +(.::) = fmap . (.:) + +-- | 'fmap' '.' '.::'. +(.:::) :: (Functor f, Functor g, Functor h,Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b))) +(.:::) = fmap . (.::) + +-- | 'fmap' '.' '.:::'. +(.::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b)))) +(.::::) = fmap . (.:::) + +-- | 'fmap' '.' '.::::'. +(.:::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j,Functor k) => (a -> b) -> f (g (h (i (j (k a))))) -> f (g (h (i (j (k b))))) +(.:::::) = fmap . (.::::) + diff --git a/Music/Theory/Instrument/Choir.hs b/Music/Theory/Instrument/Choir.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Instrument/Choir.hs @@ -0,0 +1,143 @@ +module Music.Theory.Instrument.Choir where + +import Data.List.Split {- split -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Clef as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Pitch.Name as T {- hmt -} + +-- | Voice types. +data Voice = Bass | Tenor | Alto | Soprano + deriving (Eq,Ord,Enum,Bounded,Show) + +-- | Single character abbreviation for 'Voice'. +voice_abbrev :: Voice -> Char +voice_abbrev = head . show + +-- | Standard 'Clef' for 'Voice'. +voice_clef :: Integral i => Voice -> T.Clef i +voice_clef v = + case v of + Bass -> T.Clef T.Bass 0 + Tenor -> T.Clef T.Treble (-1) + Alto -> T.Clef T.Treble 0 + Soprano -> T.Clef T.Treble 0 + +-- | Table giving ranges for 'Voice's. +type Voice_Rng_Tbl = [(Voice,(T.Pitch,T.Pitch))] + +-- | More or less standard choir ranges, /inclusive/. +voice_rng_tbl_std :: Voice_Rng_Tbl +voice_rng_tbl_std = + [(Bass,(T.d2,T.c4)) + ,(Tenor,(T.c3,T.a4)) + ,(Alto,(T.f3,T.f5)) + ,(Soprano,(T.c4,T.a5))] + +-- | More conservative ranges, /inclusive/. +voice_rng_tbl_safe :: Voice_Rng_Tbl +voice_rng_tbl_safe = + [(Bass,(T.g2,T.c4)) + ,(Tenor,(T.c3,T.f4)) + ,(Alto,(T.g3,T.c5)) + ,(Soprano,(T.c4,T.f5))] + +-- | Erroring variant. +lookup_err :: Eq a => a -> [(a,b)] -> b +lookup_err e = fromMaybe (error "lookup_err") . lookup e + +-- | Lookup voice range table. +voice_rng :: Voice_Rng_Tbl -> Voice -> (T.Pitch,T.Pitch) +voice_rng tbl v = lookup_err v tbl + +-- | Lookup 'voice_rng_tbl_std'. +voice_rng_std :: Voice -> (T.Pitch,T.Pitch) +voice_rng_std = voice_rng voice_rng_tbl_std + +-- | Lookup 'voice_rng_tbl_safe'. +voice_rng_safe :: Voice -> (T.Pitch,T.Pitch) +voice_rng_safe = voice_rng voice_rng_tbl_safe + +-- | Is /p/ '>=' /l/ and '<=' /r/. +in_range_inclusive :: Ord a => a -> (a,a) -> Bool +in_range_inclusive p (l,r) = p >= l && p <= r + +-- | Is /p/ in range for /v/, (/std/ & /safe/). +-- +-- > map (in_voice_rng T.c4) [Bass .. Soprano] +in_voice_rng :: T.Pitch -> Voice -> (Bool,Bool) +in_voice_rng p v = + (in_range_inclusive p (voice_rng_std v) + ,in_range_inclusive p (voice_rng_safe v)) + +-- | Given /tbl/ list 'Voice's that can sing 'T.Pitch'. +possible_voices :: Voice_Rng_Tbl -> T.Pitch -> [Voice] +possible_voices tbl p = + let f = in_range_inclusive p . voice_rng tbl + in filter f [Bass .. Soprano] + +-- | /std/ variant. +possible_voices_std :: T.Pitch -> [Voice] +possible_voices_std = possible_voices voice_rng_tbl_std + +-- | /safe/ variant. +possible_voices_safe :: T.Pitch -> [Voice] +possible_voices_safe = possible_voices voice_rng_tbl_safe + +-- | Enumeration of SATB voices. +satb :: [Voice] +satb = [Soprano,Alto,Tenor,Bass] + +-- | Names of 'satb'. +satb_name :: [String] +satb_name = map show satb + +-- | 'voice_abbrev' of 'satb' as 'String's. +satb_abbrev :: [String] +satb_abbrev = map (return . voice_abbrev) satb + +-- | Voice & part number. +type Part = (Voice,Int) + +-- | /k/ part choir, ordered by voice. +ch_satb_seq :: Int -> [Part] +ch_satb_seq k = [(vc,n) | vc <- satb, n <- [1..k]] + +-- | 'ch_satb_seq' grouped in parts. +-- +-- > map (map part_nm) (ch_parts 8) +ch_parts :: Int -> [[Part]] +ch_parts k = chunksOf k (ch_satb_seq k) + +-- | Abreviated name for part. +-- +-- > part_nm (Soprano,1) == "S1" +part_nm :: Part -> String +part_nm (v,n) = voice_abbrev v : show n + +-- | /k/ SATB choirs, grouped by choir. +-- +-- > k_ch_groups 2 +k_ch_groups :: Int -> [[Part]] +k_ch_groups k = + let f n = map (\p -> (p,n)) satb + in map f [1 .. k] + +-- | 'concat' of 'k_ch_groups'. +k_ch_groups' :: Int -> [Part] +k_ch_groups' = concat . k_ch_groups + +-- | Two /k/ part SATB choirs in score order. +-- +-- > map part_nm (concat (dbl_ch_parts 8)) +dbl_ch_parts :: Int -> [[Part]] +dbl_ch_parts k = + let v = satb + f p = map (\n -> (p,n)) + g = zipWith f v . replicate 4 + in concatMap g (chunksOf (k `div` 2) [1 .. k]) + +-- | 'voice_clef' for 'Part's. +mk_clef_seq :: [Part] -> [T.Clef Int] +mk_clef_seq = map (voice_clef . fst) diff --git a/Music/Theory/Interval.hs b/Music/Theory/Interval.hs --- a/Music/Theory/Interval.hs +++ b/Music/Theory/Interval.hs @@ -1,9 +1,11 @@ -- | Common music notation intervals. module Music.Theory.Interval where -import qualified Data.List as L -import Data.Maybe +import Data.List {- base -} +import Data.Maybe {- base -} + import Music.Theory.Pitch +import Music.Theory.Pitch.Note -- | Interval type or degree. data Interval_T = Unison | Second | Third | Fourth @@ -76,17 +78,17 @@ -- -- > interval_q_reverse Third Minor == Just 3 -- > interval_q_reverse Unison Diminished == Just 11 -interval_q_reverse :: Interval_T -> Interval_Q -> Maybe Integer +interval_q_reverse :: Interval_T -> Interval_Q -> Maybe Int interval_q_reverse ty qu = case lookup ty interval_q_tbl of Nothing -> Nothing - Just tbl -> fmap fst (L.find ((== qu) . snd) tbl) + Just tbl -> fmap fst (find ((== qu) . snd) tbl) -- | Semitone difference of 'Interval'. -- -- > interval_semitones (interval (Pitch C Sharp 4) (Pitch E Sharp 5)) == 16 -- > interval_semitones (interval (Pitch C Natural 4) (Pitch D Sharp 3)) == -9 -interval_semitones :: Interval -> Integer +interval_semitones :: Interval -> Int interval_semitones (Interval ty qu dir oct) = case interval_q_reverse ty qu of Just n -> let o = 12 * oct @@ -113,9 +115,9 @@ invert_ordering :: Ordering -> Ordering invert_ordering x = case x of - GT -> LT LT -> GT EQ -> EQ + GT -> LT -- | Determine 'Interval' between two 'Pitch'es. -- @@ -183,8 +185,8 @@ -- | Transpose a 'Pitch' by an 'Interval'. -- -- > transpose (Interval Third Diminished LT 0) (Pitch C Sharp 4) == Pitch E Flat 4 -transpose :: Interval -> Pitch -> Pitch -transpose i ip = +pitch_transpose :: Interval -> Pitch -> Pitch +pitch_transpose i ip = let (Pitch p_n p_a p_o) = ip (Interval i_t i_q i_d i_o) = i i_d' = if i_d == GT @@ -219,5 +221,83 @@ circle_of_fifths x = let p4 = Interval Fourth Perfect LT 0 p5 = Interval Fifth Perfect LT 0 - mk y = take 12 (iterate (transpose y) x) + mk y = take 12 (iterate (pitch_transpose y) x) in (mk p4,mk p5) + +-- | Parse a positive integer into interval type and octave +-- displacement. +-- +-- > mapMaybe parse_interval_type (map show [1 .. 15]) +parse_interval_type :: String -> Maybe (Interval_T,Octave) +parse_interval_type n = + case reads n of + [(n',[])] -> if n' == 0 + then Nothing + else let (o,t) = (n' - 1) `divMod` 7 + in Just (toEnum t,fromIntegral o) + _ -> Nothing + +-- | Parse interval quality notation. +-- +-- > mapMaybe parse_interval_quality "dmPMA" == [minBound .. maxBound] +parse_interval_quality :: Char -> Maybe Interval_Q +parse_interval_quality q = + let c = zip "dmPMA" [0..] + in fmap toEnum (lookup q c) + +-- | Degree of interval type and octave displacement. Inverse of +-- 'parse_interval_type'. +-- +-- > map interval_type_degree [(Third,0),(Second,1),(Unison,2)] == [3,9,15] +interval_type_degree :: (Interval_T,Octave) -> Int +interval_type_degree (t,o) = fromEnum t + 1 + (fromIntegral o * 7) + +-- | Inverse of 'parse_interval_quality. +interval_quality_pp :: Interval_Q -> Char +interval_quality_pp q = "dmPMA" !! fromEnum q + +-- | Parse standard common music interval notation. +-- +-- > let i = mapMaybe parse_interval (words "P1 d2 m2 M2 A3 P8 +M9 -M2") +-- > in unwords (map interval_pp i) == "P1 d2 m2 M2 A3 P8 M9 -M2" +-- +-- > mapMaybe (fmap interval_octave . parse_interval) (words "d1 d8 d15") == [-1,0,1] +parse_interval :: String -> Maybe Interval +parse_interval i = + let unisons = [(Perfect,Unison) + ,(Diminished,Second) + ,(Augmented,Seventh)] + f q n = case (parse_interval_quality q,parse_interval_type n) of + (Just q',Just (n',o)) -> + let o' = if (q',n') == (Diminished,Unison) + then o - 1 + else o + d = if o' == 0 && (q',n') `elem` unisons + then EQ + else LT + in Just (Interval n' q' d o') + _ -> Nothing + in case i of + '-':q:n -> fmap invert_interval (f q n) + '+':q:n -> f q n + q:n -> f q n + _ -> Nothing + +-- | Pretty printer for intervals, inverse of 'parse_interval'. +interval_pp :: Interval -> String +interval_pp (Interval n q d o) = + let d' = if d == GT then ('-' :) else id + in d' (interval_quality_pp q : show (interval_type_degree (n,o))) + +-- | Standard names for the intervals within the octave, divided into +-- perfect, major and minor at the left, and diminished and augmented +-- at the right. +-- +-- > let {bimap f (p,q) = (f p,f q) +-- > ;f = mapMaybe (fmap interval_semitones . parse_interval)} +-- > in bimap f std_interval_names +std_interval_names :: ([String],[String]) +std_interval_names = + let pmM = "P1 m2 M2 m3 M3 P4 P5 m6 M6 m7 M7 P8" + dA = "d2 A1 d3 A2 d4 A3 d5 A4 d6 A5 d7 A6 d8 A7" + in (words pmM,words dA) 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 @@ -3,12 +3,14 @@ -- Translated by Henning Lohner. module Music.Theory.Interval.Barlow_1987 where -import Data.List -import Data.Maybe +import Data.List {- base -} +import Data.Maybe {- base -} import Data.Numbers.Primes {- primes -} -import Data.Ratio -import Text.Printf +import Data.Ratio {- base -} +import Text.Printf {- base -} +import Music.Theory.Tuning + -- | Barlow's /indigestibility/ function for prime numbers. -- -- > map barlow [1,2,3,5,7,11,13] == [0,1,8/3,32/5,72/7,200/11,288/13] @@ -113,12 +115,6 @@ harmonicity_r :: (Integral a,Fractional b) => (a -> b) -> Ratio a -> b harmonicity_r pv = harmonicity pv . from_rational --- | Interval ratio to cents. --- --- > map cents [16%15,16%9] == [111.73128526977776,996.0899982692251] -cents :: (Real a,Floating b) => a -> b -cents x = 1200 * logBase 2 (realToFrac x) - -- | 'uncurry' ('%'). to_rational :: Integral a => (a,a) -> Ratio a to_rational = uncurry (%) @@ -140,7 +136,7 @@ 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) = (cents i,rational_prime_factors_t 6 (from_rational i),i,j) + k (i,j) = (fratio_to_cents i,rational_prime_factors_t 6 (from_rational i),i,j) in map k (filter f (zip r h)) -- | Pretty printer for 'Table_2_Row' values. diff --git a/Music/Theory/Interval/Spelling.hs b/Music/Theory/Interval/Spelling.hs --- a/Music/Theory/Interval/Spelling.hs +++ b/Music/Theory/Interval/Spelling.hs @@ -30,17 +30,18 @@ -- spellings are poor, ie. (f,g#). -- -- > interval_simplify (Interval Second Augmented LT 0) == Interval Third Minor LT 0 +-- > interval_simplify (Interval Seventh Augmented GT 0) == Interval Unison Perfect GT 1 interval_simplify :: Interval -> Interval interval_simplify x = let (Interval ty qu d o) = x - (qu',ty') = case (qu,ty) of - (Diminished,Second) -> (Perfect,Unison) - (Diminished,Third) -> (Major,Second) - (Augmented,Second) -> (Minor,Third) - (Augmented,Third) -> (Perfect,Fourth) - (Diminished,Sixth) -> (Perfect,Fifth) - (Diminished,Seventh) -> (Major,Sixth) - (Augmented,Sixth) -> (Minor,Seventh) - -- (Augmented,Seventh) -> (Perfect,Octave) - _ -> (qu,ty) - in Interval ty' qu' d o + (qu',ty',o') = case (qu,ty) of + (Diminished,Second) -> (Perfect,Unison,o) + (Diminished,Third) -> (Major,Second,o) + (Augmented,Second) -> (Minor,Third,o) + (Augmented,Third) -> (Perfect,Fourth,o) + (Diminished,Sixth) -> (Perfect,Fifth,o) + (Diminished,Seventh) -> (Major,Sixth,o) + (Augmented,Sixth) -> (Minor,Seventh,o) + (Augmented,Seventh) -> (Perfect,Unison,o + 1) + _ -> (qu,ty,o) + in Interval ty' qu' d o' diff --git a/Music/Theory/Key.hs b/Music/Theory/Key.hs --- a/Music/Theory/Key.hs +++ b/Music/Theory/Key.hs @@ -1,9 +1,11 @@ -- | Common music keys. module Music.Theory.Key where -import Data.List +import Data.List {- base -} + import Music.Theory.Pitch import Music.Theory.Pitch.Name +import Music.Theory.Pitch.Note import Music.Theory.Interval -- | Enumeration of common music notation modes. diff --git a/Music/Theory/List.hs b/Music/Theory/List.hs --- a/Music/Theory/List.hs +++ b/Music/Theory/List.hs @@ -1,10 +1,11 @@ --- | Shared list functions. +-- | List functions. module Music.Theory.List where -import Data.Function -import Data.List +import Data.Function {- base -} +import Data.List {- base -} +import qualified Data.List.Ordered as O {- data-ordlist -} import Data.List.Split {- split -} -import Data.Maybe +import Data.Maybe {- base -} -- | Bracket sequence with left and right values. -- @@ -12,6 +13,13 @@ bracket :: (a,a) -> [a] -> [a] bracket (l,r) x = l : x ++ [r] +-- | Variant where brackets are sequences. +-- +-- > bracket_l ("<:",":>") "1,2,3" == "<:1,2,3:>" +bracket_l :: ([a],[a]) -> [a] -> [a] +bracket_l (l,r) s = l ++ s ++ r + +-- | Generic form of 'rotate_left'. genericRotate_left :: Integral i => i -> [a] -> [a] genericRotate_left n = let f (p,q) = q ++ p @@ -24,6 +32,7 @@ rotate_left :: Int -> [a] -> [a] rotate_left = genericRotate_left +-- | Generic form of 'rotate_right'. genericRotate_right :: Integral n => n -> [a] -> [a] genericRotate_right n = reverse . genericRotate_left n . reverse @@ -35,6 +44,7 @@ -- | Rotate left by /n/ 'mod' /#p/ places. -- +-- > rotate 1 [1..3] == [2,3,1] -- > rotate 8 [1..5] == [4,5,1,2,3] rotate :: (Integral n) => n -> [a] -> [a] rotate n p = @@ -53,6 +63,7 @@ rotations :: [a] -> [[a]] rotations p = map (`rotate_left` p) [0 .. length p - 1] +-- | Generic form of 'adj2'. genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)] genericAdj2 n l = case l of @@ -85,11 +96,25 @@ -- | Interleave elements of /p/ and /q/. -- -- > interleave [1..3] [4..6] == [1,4,2,5,3,6] +-- > interleave ".+-" "abc" == ".a+b-c" +-- > interleave [1..3] [] == [] interleave :: [b] -> [b] -> [b] interleave p q = let u (i,j) = [i,j] in concatMap u (zip p q) +-- | Variant that continues with the longer input. +-- +-- > interleave_continue ".+-" "abc" == ".a+b-c" +-- > interleave_continue [1..3] [] == [1..3] +-- > interleave_continue [] [1..3] == [1..3] +interleave_continue :: [a] -> [a] -> [a] +interleave_continue p q = + case (p,q) of + ([],_) -> q + (_,[]) -> p + (i:p',j:q') -> i : j : interleave_continue p' q' + -- | 'interleave' of 'rotate_left' by /i/ and /j/. -- -- > interleave_rotations 9 3 [1..13] == [10,4,11,5,12,6,13,7,1,8,2,9,3,10,4,11,5,12,6,13,7,1,8,2,9,3] @@ -143,13 +168,22 @@ -- * Association lists --- | Collate values of equal keys at /assoc/ list. +-- | Given accesors for /key/ and /value/ collate input. -- --- > collate [(1,'a'),(2,'b'),(1,'c')] == [(1,"ac"),(2,"b")] +-- > let r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")] +-- > in collate_on fst snd (zip "ABCBCD" "abcdef") +collate_on :: (Eq k,Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])] +collate_on f g = + let h l = case l of + [] -> error "collate_on" + l0:_ -> (f l0,map g l) + in map h . groupBy ((==) `on` f) . sortBy (compare `on` f) + +-- | 'collate_on' of 'fst' and 'snd'. +-- +-- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")] collate :: Ord a => [(a,b)] -> [(a,[b])] -collate = - let f l = (fst (head l), map snd l) - in map f . groupBy ((==) `on` fst) . sortBy (compare `on` fst) +collate = collate_on fst snd -- | Make /assoc/ list with given /key/. -- @@ -163,11 +197,23 @@ dx_d :: (Num a) => a -> [a] -> [a] dx_d = scanl (+) +-- | Variant that takes initial value and separates final value. This +-- is an appropriate function for 'mapAccumL'. +-- +-- > dx_d' 5 [1,2,3] == (11,[5,6,8]) +-- > dx_d' 0 [1,1,1] == (3,[0,1,2]) +dx_d' :: Num t => t -> [t] -> (t,[t]) +dx_d' n l = + case reverse (scanl (+) n l) of + e:r -> (e,reverse r) + _ -> error "dx_d'" + -- | Integrate, ie. pitch class segment to interval sequence. -- -- > d_dx [5,6,8,11] == [1,2,3] +-- > d_dx [] == [] d_dx :: (Num a) => [a] -> [a] -d_dx l = zipWith (-) (tail l) l +d_dx l = if null l then [] else zipWith (-) (tail l) l -- | Elements of /p/ not in /q/. -- @@ -204,18 +250,26 @@ [i] -> i _ -> error "elem_index_unique" +-- | Basis of 'find_bounds'. There is an option to consider the last +-- element specially, and if equal to the last span is given. +find_bounds' :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t) +find_bounds' scl f l x = + let g (p,q) = f p x /= GT && f q x == GT + h (p,q) = f p x /= GT && f q x /= LT + h' = if scl then h else g + in case l of + [] -> Nothing + [e] -> if h' e then Just e else Nothing + e:l' -> if g e then Just e else find_bounds' scl f l' x + -- | Find adjacent elements of list that bound element under given -- comparator. -- --- > let f = find_bounds compare (adj [1..5]) --- > in map f [1,3.5,5] == [Just (1,2),Just (3,4),Nothing] -find_bounds :: (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t) -find_bounds f l x = - case l of - (p,q):l' -> if f p x /= GT && f q x == GT - then Just (p,q) - else find_bounds f l' x - _ -> Nothing +-- > let {f = find_bounds True compare [1..5] +-- > ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]} +-- > in map f [0,1,3.5,5] == r +find_bounds :: Bool -> (t -> s -> Ordering) -> [t] -> s -> Maybe (t,t) +find_bounds scl f l = find_bounds' scl f (adj2 1 l) -- | Variant of 'drop' from right of list. -- @@ -223,6 +277,12 @@ dropRight :: Int -> [a] -> [a] dropRight n = reverse . drop n . reverse +-- | Variant of 'dropWhile' from right of list. +-- +-- > dropWhileRight Data.Char.isDigit "A440" == "A" +dropWhileRight :: (a -> Bool) -> [a] -> [a] +dropWhileRight p = reverse . dropWhile p . reverse + -- | Apply /f/ at first element, and /g/ at all other elements. -- -- > at_head negate id [1..5] == [-1,2,3,4,5] @@ -260,6 +320,11 @@ e:l' -> Just e : map (const Nothing) l' in concatMap f . group +-- | 'Data.List.groupBy' does not make adjacent comparisons, it +-- compares each new element to the start of the group. This function +-- is the adjacent variant. +-- +-- > groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3,2,4],[1,5,9]] -- > adjacent_groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3],[2,4],[1,5,9]] adjacent_groupBy :: (a -> a -> Bool) -> [a] -> [[a]] adjacent_groupBy f p = @@ -272,32 +337,120 @@ then (x:r0) : r' else [x] : r --- > group_just [Just 1,Nothing,Nothing,Just 4,Just 5] +-- | 'groupBy' on /structure/ of 'Maybe', ie. all 'Just' compare equal. +-- +-- > let r = [[Just 1],[Nothing,Nothing],[Just 4,Just 5]] +-- > in group_just [Just 1,Nothing,Nothing,Just 4,Just 5] == r group_just :: [Maybe a] -> [[Maybe a]] group_just = groupBy ((==) `on` isJust) +-- | Predicate to determine if all elements of the list are '=='. +all_eq :: Eq n => [n] -> Bool +all_eq = (== 1) . length . nub + +-- | 'groupBy' of 'sortBy'. +-- +-- > let r = [[('1','a'),('1','c')],[('2','d')],[('3','b'),('3','e')]] +-- > in sort_group_on fst (zip "13123" "abcde") == r +sort_group_on :: Ord b => (a -> b) -> [a] -> [[a]] +sort_group_on f = groupBy ((==) `on` f) . sortBy (compare `on` f) + +-- | Maybe cons element onto list. +-- +-- > Nothing `mcons` "something" == "something" +-- > Just 's' `mcons` "omething" == "something" +mcons :: Maybe a -> [a] -> [a] +mcons e l = maybe l (:l) e + +-- * Ordering + +-- | Comparison function type. +type Compare_F a = a -> a -> Ordering + +-- | If /f/ compares 'EQ', defer to /g/. +two_stage_compare :: Compare_F a -> Compare_F a -> Compare_F a +two_stage_compare f g p q = + case f p q of + EQ -> g p q + r -> r + +-- | Invert 'Ordering'. +ordering_invert :: Ordering -> Ordering +ordering_invert o = + case o of + LT -> GT + EQ -> EQ + GT -> LT + +-- | Sort sequence /a/ based on ordering of sequence /b/. +-- +-- > sort_to "abc" [1,3,2] == "acb" +-- > sort_to "adbce" [1,4,2,3,5] == "abcde" +sort_to :: Ord i => [e] -> [i] -> [e] +sort_to e = map fst . sortBy (compare `on` snd) . zip e + +-- | 'flip' of 'sort_to'. +-- +-- > sort_on [1,4,2,3,5] "adbce" == "abcde" +sort_on :: Ord i => [i] -> [e] -> [e] +sort_on = flip sort_to + +-- | 'sortBy' of 'two_stage_compare'. +sort_by_two_stage :: (Ord b,Ord c) => (a -> b) -> (a -> c) -> [a] -> [a] +sort_by_two_stage f g = sortBy (two_stage_compare (compare `on` f) (compare `on` g)) + -- | Given a comparison function, merge two ascending lists. -- -- > mergeBy compare [1,3,5] [2,4] == [1..5] -mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -mergeBy f p q = - case (p,q) of - ([],_) -> q - (_,[]) -> p - (i:p',j:q') -> case f i j of - GT -> j : mergeBy f p q' - _ -> i : mergeBy f p' q +merge_by :: Compare_F a -> [a] -> [a] -> [a] +merge_by = O.mergeBy +-- | 'O.mergeBy' of 'two_stage_compare'. +merge_by_two_stage :: Ord b => (a -> b) -> Compare_F c -> (a -> c) -> [a] -> [a] -> [a] +merge_by_two_stage f cmp g = O.mergeBy (two_stage_compare (compare `on` f) (cmp `on` g)) + -- | 'mergeBy' 'compare'. merge :: Ord a => [a] -> [a] -> [a] -merge = mergeBy compare +merge = O.merge --- | 'merge' a set of ordered sequences. +-- | Merge list of sorted lists given comparison function. Note that +-- this is not equal to 'O.mergeAll'. +merge_set_by :: (a -> a -> Ordering) -> [[a]] -> [a] +merge_set_by f = foldr (merge_by f) [] + +-- | 'merge_set_by' of 'compare'. -- --- > merge_set [[1,3..9],[2,4..8],[10]] == [1..10] +-- > merge_set [[1,3,5,7,9],[2,4,6,8],[10]] == [1..10] merge_set :: Ord a => [[a]] -> [a] -merge_set p = - case p of - [] -> [] - [i] -> i - i:p' -> merge i (merge_set p') +merge_set = merge_set_by compare + +{-| 'merge_by' variant that joins (resolves) equal elements. + +> let {left p _ = p +> ;right _ q = q +> ;cmp = compare `on` fst +> ;p = zip [1,3,5] "abc" +> ;q = zip [1,2,3] "ABC" +> ;left_r = [(1,'a'),(2,'B'),(3,'b'),(5,'c')] +> ;right_r = [(1,'A'),(2,'B'),(3,'C'),(5,'c')]} +> in merge_by_resolve left cmp p q == left_r && +> merge_by_resolve right cmp p q == right_r + +-} +merge_by_resolve :: (a -> a -> a) -> Compare_F a -> [a] -> [a] -> [a] +merge_by_resolve jn cmp = + let recur p q = + case (p,q) of + ([],_) -> q + (_,[]) -> p + (l:p',r:q') -> case cmp l r of + LT -> l : recur p' q + EQ -> jn l r : recur p' q' + GT -> r : recur p q' + in recur + +-- * Bimap + +-- | Apply /f/ to both elements of a two-tuple, ie. 'bimap' /f/ /f/. +bimap1 :: (t -> u) -> (t,t) -> (u,u) +bimap1 f (p,q) = (f p,f q) diff --git a/Music/Theory/Math.hs b/Music/Theory/Math.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math.hs @@ -0,0 +1,98 @@ +-- | Math functions. +module Music.Theory.Math where + +import Data.Maybe {- base -} +import Data.Ratio {- base -} +import Numeric {- base -} + +-- | Real (alias for 'Double'). +type R = Double + +-- | +integral_and_fractional_parts :: (Integral i, RealFrac t) => t -> (i,t) +integral_and_fractional_parts n = + if n >= 0 + then let n' = floor n in (n',n - fromIntegral n') + else let n' = ceiling n in (n',n - fromIntegral n') + +-- | Type specialised. +integer_and_fractional_parts :: RealFrac t => t -> (Integer,t) +integer_and_fractional_parts = integral_and_fractional_parts + +-- | +-- +-- > import Sound.SC3.Plot {- hsc3-plot -} +-- > plotTable1 (map fractional_part [-2.0,-1.99 .. 2.0]) +fractional_part :: RealFrac a => a -> a +fractional_part = snd . integer_and_fractional_parts + +-- | +-- +-- > plotTable1 (map sawtooth_wave [-2.0,-1.99 .. 2.0]) +sawtooth_wave :: RealFrac a => a -> a +sawtooth_wave n = n - fromInteger (floor n) + +-- | Pretty printer for 'Rational' that elides denominators of @1@. +-- +-- > map rational_pp [1,3/2,2] == ["1","3/2","2"] +rational_pp :: (Show a,Integral a) => Ratio a -> String +rational_pp r = + let n = numerator r + d = denominator r + in if d == 1 + then show n + else concat [show n,"/",show d] + +-- | Pretty print ratio as @:@ separated integers. +-- +-- > map ratio_pp [1,3/2,2] == ["1:1","3:2","2:1"] +ratio_pp :: Rational -> String +ratio_pp r = + let (n,d) = rational_nd r + in concat [show n,":",show d] + +-- | Predicate that is true if @n/d@ can be simplified, ie. where +-- 'gcd' of @n@ and @d@ is not @1@. +-- +-- > let r = [False,True,False] +-- > in map rational_simplifies [(2,3),(4,6),(5,7)] == r +rational_simplifies :: Integral a => (a,a) -> Bool +rational_simplifies (n,d) = gcd n d /= 1 + +-- | 'numerator' and 'denominator' of rational. +rational_nd :: Integral t => Ratio t -> (t,t) +rational_nd r = (numerator r,denominator r) + +-- | Rational as a whole number, or 'Nothing'. +rational_whole :: Integral a => Ratio a -> Maybe a +rational_whole r = if denominator r == 1 then Just (numerator r) else Nothing + +-- | Erroring variant. +rational_whole_err :: Integral a => Ratio a -> a +rational_whole_err = fromMaybe (error "rational_whole") . rational_whole + +-- | Variant of 'showFFloat'. The 'Show' instance for floats resorts +-- to exponential notation very readily. +-- +-- > [show 0.01,realfloat_pp 2 0.01] == ["1.0e-2","0.01"] +realfloat_pp :: RealFloat a => Int -> a -> String +realfloat_pp k n = showFFloat (Just k) n "" + +-- | Type specialised 'realfloat_pp'. +float_pp :: Int -> Float -> String +float_pp = realfloat_pp + +-- | Type specialised 'realfloat_pp'. +double_pp :: Int -> Double -> String +double_pp = realfloat_pp + +-- | Show /only/ positive and negative values, always with sign. +-- +-- > map num_diff_str [-2,-1,0,1,2] == ["-2","-1","","+1","+2"] +-- > map show [-2,-1,0,1,2] == ["-2","-1","0","1","2"] +num_diff_str :: (Num a, Ord a, Show a) => a -> String +num_diff_str n = + case compare n 0 of + LT -> '-' : show (abs n) + EQ -> "" + GT -> '+' : show n diff --git a/Music/Theory/Maybe.hs b/Music/Theory/Maybe.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Maybe.hs @@ -0,0 +1,80 @@ +-- | Extensions to "Data.Maybe". +module Music.Theory.Maybe where + +-- import Data.Maybe {- base -} + +-- | Variant of unzip. +-- +-- > let r = ([Just 1,Nothing,Just 3],[Just 'a',Nothing,Just 'c']) +-- > in maybe_unzip [Just (1,'a'),Nothing,Just (3,'c')] == r +maybe_unzip :: [Maybe (a,b)] -> ([Maybe a],[Maybe b]) +maybe_unzip = + let f x = case x of + Nothing -> (Nothing,Nothing) + Just (i,j) -> (Just i,Just j) + in unzip . map f + +-- | Replace 'Nothing' elements with last 'Just' value. This does not +-- alter the length of the list. +-- +-- > maybe_latch 1 [Nothing,Just 2,Nothing,Just 4] == [1,2,2,4] +maybe_latch :: a -> [Maybe a] -> [a] +maybe_latch i x = + case x of + [] -> [] + Just e:x' -> e : maybe_latch e x' + Nothing:x' -> i : maybe_latch i x' + +-- | Variant requiring initial value is not 'Nothing'. +-- +-- > maybe_latch1 [Just 1,Nothing,Nothing,Just 4] == [1,1,1,4] +maybe_latch1 :: [Maybe a] -> [a] +maybe_latch1 = maybe_latch (error "maybe_latch1") + +-- | 'map' of 'fmap'. +-- +-- > maybe_map negate [Nothing,Just 2] == [Nothing,Just (-2)] +maybe_map :: (a -> b) -> [Maybe a] -> [Maybe b] +maybe_map = map . fmap + +-- | If either is 'Nothing' then 'False', else /eq/ of values. +maybe_eq_by :: (t -> u -> Bool) -> Maybe t -> Maybe u -> Bool +maybe_eq_by eq_fn p q = + case (p,q) of + (Just p',Just q') -> eq_fn p' q' + _ -> False + +-- | Join two values, either of which may be missing. +maybe_join' :: (s -> t) -> (s -> s -> t) -> Maybe s -> Maybe s -> Maybe t +maybe_join' f g p q = + case (p,q) of + (Nothing,_) -> fmap f q + (_,Nothing) -> fmap f p + (Just p',Just q') -> Just (p' `g` q') + +-- | 'maybe_join'' of 'id' +maybe_join :: (t -> t -> t) -> Maybe t -> Maybe t -> Maybe t +maybe_join = maybe_join' id + +-- | Apply predicate inside 'Maybe'. +-- +-- > maybe_predicate even (Just 3) == Nothing +maybe_predicate :: (a -> Bool) -> Maybe a -> Maybe a +maybe_predicate f i = + case i of + Nothing -> Nothing + Just j -> if f j then Just j else Nothing + +-- | 'map' of 'maybe_predicate'. +-- +-- > let r = [Nothing,Nothing,Nothing,Just 4] +-- > in maybe_filter even [Just 1,Nothing,Nothing,Just 4] == r +maybe_filter :: (a -> Bool) -> [Maybe a] -> [Maybe a] +maybe_filter = map . maybe_predicate + +-- | Variant of 'Data.List.filter' that retains 'Nothing' as a +-- placeholder for removed elements. +-- +-- > filter_maybe even [1..4] == [Nothing,Just 2,Nothing,Just 4] +filter_maybe :: (a -> Bool) -> [a] -> [Maybe a] +filter_maybe f = maybe_filter f . map Just 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 @@ -7,6 +7,8 @@ import Data.Numbers.Primes {- primes -} --import Debug.Trace +import Music.Theory.Math (R) + traceShow :: a -> b -> b traceShow _ x = x @@ -39,9 +41,6 @@ then error (show ("mod'",a,b,r)) else r --- | Alias for 'Double' (quieten compiler). -type R = Double - -- | Specialised variant of 'fromIntegral'. to_r :: (Integral n,Show n) => n -> R to_r = fromIntegral @@ -173,7 +172,7 @@ -- > relative_to_length [0..5] == [0.0,0.2,0.4,0.6,0.8,1.0] relative_to_length :: (Real a, Fractional b) => [a] -> [b] relative_to_length x = - let n = genericLength x - (1::Integer) + let n = length x - 1 in map ((/ fromIntegral n) . realToFrac) x -- | Variant of 'indispensibilities' that scales value to lie in diff --git a/Music/Theory/Metric/Buchler_1998.hs b/Music/Theory/Metric/Buchler_1998.hs --- a/Music/Theory/Metric/Buchler_1998.hs +++ b/Music/Theory/Metric/Buchler_1998.hs @@ -3,13 +3,14 @@ -- thesis, University of Rochester, 1998 module Music.Theory.Metric.Buchler_1998 where -import Data.List -import Data.Ratio -import qualified Music.Theory.List as L -import qualified Music.Theory.Z12.Forte_1973 as F -import qualified Music.Theory.Set.List as S -import Music.Theory.Z12 +import Data.List {- base -} +import Data.Ratio {- base -} +import qualified Music.Theory.List as T +import qualified Music.Theory.Z12.Forte_1973 as T +import qualified Music.Theory.Set.List as T +import Music.Theory.Z12 (Z12) + -- | Predicate for list with cardinality /n/. of_c :: Integral n => n -> [a] -> Bool of_c n = (== n) . genericLength @@ -18,7 +19,7 @@ -- -- > sc_table_n 2 == [[0,1],[0,2],[0,3],[0,4],[0,5],[0,6]] sc_table_n :: (Integral n) => n -> [[Z12]] -sc_table_n n = filter (of_c n) (map snd F.sc_table) +sc_table_n n = filter (of_c n) (map snd T.sc_table) -- | Minima and maxima of ICV of SCs of cardinality /n/. -- @@ -26,7 +27,7 @@ icv_minmax :: (Integral n, Integral b) => n -> ([b], [b]) icv_minmax n = let t = sc_table_n n - i = transpose (map F.icv t) + i = transpose (map T.icv t) in (map minimum i,map maximum i) data R = MIN | MAX deriving (Eq,Show) @@ -45,7 +46,7 @@ satv_f :: (Integral n) => ((n,n,n) -> D n) -> [Z12] -> [D n] satv_f f p = let n = length p - i = F.icv p + i = T.icv p (l,r) = icv_minmax n in map f (zip3 l i r) @@ -55,13 +56,13 @@ satv_e_pp :: Show i => [D i] -> String satv_e_pp = let f (i,j) = r_pp i ++ show j - in L.bracket ('<','>') . intercalate "," . map f + in T.bracket ('<','>') . intercalate "," . map f type SATV i = ([D i],[D i]) -- | Pretty printer for 'SATV'. satv_pp :: Show i => SATV i -> String -satv_pp (i,j) = L.bracket ('(',')') (satv_e_pp i ++ "," ++ satv_e_pp j) +satv_pp (i,j) = T.bracket ('(',')') (satv_e_pp i ++ "," ++ satv_e_pp j) -- | @SATVa@ measure. -- @@ -163,12 +164,12 @@ satsim_table :: Integral i => [(([Z12],[Z12]),Ratio i)] satsim_table = let f (i,j) = ((i,j),satsim i j) - t = filter ((`notElem` [0,1,12]) . length) (map snd F.sc_table) - in map f (S.pairs t) + t = filter ((`notElem` [0,1,12]) . length) (map snd T.sc_table) + in map f (T.pairs t) -- | Histogram of values at 'satsim_table'. -- --- > satsim_table_histogram == L.histogram (map snd satsim_table) +-- > satsim_table_histogram == T.histogram (map snd satsim_table) satsim_table_histogram :: Integral i => [(Ratio i,i)] satsim_table_histogram = [(0,132),(1/49,4),(1/30,4),(2/49,16),(2/39,16),(18,8),(2/33,12),(3/49,30),(15,12),(14,144),(13,56),(4/49,72),(2/23,14),(2/21,304),(10,6),(5/49,132),(4/39,160),(1/9,264),(4/33,16),(6/49,152),(1/8,12),(5/39,108),(3/23,4),(25,44),(1/7,487),(7/46,6),(23,132),(8/49,304),(1/6,116),(4/23,86),(7/40,6),(7/39,444),(21,48),(9/49,208),(4/21,1116),(9/46,84),(1/5,68),(10/49,298),(8/39,472),(5/24,4),(7/33,88),(34,394),(5/23,176),(2/9,516),(11/49,378),(9/40,8),(33,176),(7/30,116),(11/46,172),(8/33,64),(12/49,314),(1/4,10),(10/39,336),(7/27,4),(6/23,276),(9/34,2),(13/49,374),(45,124),(31,192),(11/40,4),(58,56),(11/39,376),(13/46,298),(2/7,1297),(7/24,48),(8/27,8),(30,226),(10/33,148),(7/23,204),(15/49,228),(43,384),(11/34,6),(13/40,50),(15/46,272),(16/49,196),(1/3,1528),(17/49,132),(8/23,230),(7/20,128),(67,6),(54,82),(14/39,144),(41,160),(11/30,168),(18/49,74),(17/46,228),(10/27,32),(3/8,238),(8/21,412),(53,160),(19/49,84),(78,76),(9/23,94),(13/33,284),(2/5,310),(11/27,44),(20/49,76),(16/39,376),(77,14),(19/46,150),(52,128),(14/33,156),(17/40,154),(3/7,81),(13/30,108),(10/23,114),(17/39,236),(15/34,4),(4/9,460),(22/49,10),(9/20,96),(51,172),(21/46,124),(11/24,144),(63,112),(75,84),(23/49,6),(87,28),(19/40,96),(10/21,84),(11/23,28),(13/27,188),(16/33,52),(19/39,160),(24/49,8),(1/2,545),(25/49,2),(20/39,144),(17/33,100),(14/27,296),(12/23,64),(21/40,42),(97,48),(85,56),(15/28,1),(73,64),(13/24,32),(25/46,66),(61,36),(11/20,18),(27/49,24),(5/9,192),(19/34,132),(22/39,24),(13/23,18),(17/30,40),(4/7,176),(23/40,32),(19/33,16),(72,28),(27/46,56),(107,84),(23/39,20),(29/49,26),(16/27,72),(3/5,14),(20/33,4),(14/23,10),(30/49,24),(21/34,120),(5/8,28),(17/27,36),(31/49,22),(71,16),(94,22),(117,72),(13/20,4),(32/49,14),(2/3,14),(27/40,6),(23/34,14),(19/28,1),(70,4),(19/27,4),(127,24),(5/7,10),(25/34,4),(3/4,7),(7/9,12),(114,4),(17/21,4),(23/28,7),(5/6,20),(6/7,11),(8/9,12),(25/28,16),(19/21,38),(112,4),(134,7),(178,18),(20/21,12),(1,32)] diff --git a/Music/Theory/Permutations.hs b/Music/Theory/Permutations.hs --- a/Music/Theory/Permutations.hs +++ b/Music/Theory/Permutations.hs @@ -1,9 +1,10 @@ -- | Permutation functions. module Music.Theory.Permutations where -import qualified Data.Permute as P +import qualified Data.Permute as P {- permutation -} +import Numeric (showHex) {- base -} + import qualified Music.Theory.List as L -import Numeric (showHex) -- | Factorial function. -- diff --git a/Music/Theory/Permutations/Morris_1984.hs b/Music/Theory/Permutations/Morris_1984.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Permutations/Morris_1984.hs @@ -0,0 +1,216 @@ +-- | Place notation (method ringing). +-- +-- Morris, R. G. T. "Place Notation" +-- Central Council of Church Bell Ringers (1984). +-- +module Music.Theory.Permutations.Morris_1984 where + +import Data.Char {- base -} +import Data.List {- base -} +import Data.List.Split {- split -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Permutations as T {- hmt -} + +-- | A change either swaps all adjacent bells, or holds a subset of bells. +data Change = Swap_All | Hold [Int] deriving (Eq,Show) + +-- | A method is a sequence of changes, if symmetrical only have the +-- changes are given and the lead end. +data Method = Method [Change] (Maybe Change) deriving (Eq,Show) + +-- | Compete list of 'Change's at 'Method', writing out symmetries. +method_changes :: Method -> [Change] +method_changes (Method p q) = + case q of + Nothing -> p + Just q' -> p ++ tail (reverse p) ++ [q'] + +-- | Parse a change notation. +-- +-- > map parse_change ["-","x","38"] == [Swap_All,Swap_All,Hold [3,8]] +parse_change :: String -> Change +parse_change s = if is_swap_all s then Swap_All else Hold (to_abbrev s) + +-- | Separate changes. +-- +-- > split_changes "-38-14-1258-36-14-58-16-78" +-- > split_changes "345.145.5.1.345" == ["345","145","5","1","345"] +split_changes :: String -> [String] +split_changes = filter (/= ".") . split (dropInitBlank (oneOf "-x.")) + +-- | Parse 'Method' from the sequence of changes with possible lead end. +-- +-- > parse_method ("-38-14-1258-36-14-58-16-78",Just "12") +parse_method :: (String,Maybe String) -> Method +parse_method (p,q) = + let c = map parse_change (split_changes p) + le = fmap parse_change q + in Method c le + +-- > map is_swap_all ["-","x","38"] == [True,True,False] +is_swap_all :: String -> Bool +is_swap_all s = + case s of + [c] -> c `elem` "-x" + _ -> False + +-- | Swap elemets of two-tuple (pair). +-- +-- > swap_pair (1,2) == (2,1) +swap_pair :: (s,t) -> (t,s) +swap_pair (p,q) = (q,p) + +-- | Flatten list of pairs. +-- +-- > flatten_pairs [(1,2),(3,4)] == [1..4] +flatten_pairs :: [(a,a)] -> [a] +flatten_pairs l = + case l of + [] -> [] + (p,q):l' -> p : q : flatten_pairs l' + +-- | Swap all adjacent pairs at list. +-- +-- > swap_all [1 .. 8] == [2,1,4,3,6,5,8,7] +swap_all :: [a] -> [a] +swap_all = flatten_pairs . map swap_pair . T.adj2 2 + +-- | Parse abbreviated 'Hold' notation, characters are hexedecimal. +-- +-- > to_abbrev "38A" == [3,8,10] +to_abbrev :: String -> [Int] +to_abbrev = map digitToInt + +-- | Given a 'Hold' notation, generate permutation cycles. +-- +-- > let r = [Right (1,2),Left 3,Right (4,5),Right (6,7),Left 8] +-- > in gen_swaps 8 [3,8] == r +-- +-- > let r = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)] +-- > gen_swaps 8 [1,2] == r +gen_swaps :: (Num t, Ord t) => t -> [t] -> [Either t (t,t)] +gen_swaps k = + let close n = if n < k then Right (n,n + 1) : close (n + 2) else [] + rec n l = case l of + [] -> close n + m:l' -> if n < m + then Right (n,n+1) : rec (n + 2) l + else Left n : rec (m + 1) l' + in rec 1 + +-- | Two-tuple to two element list. +pair_to_list :: (t,t) -> [t] +pair_to_list (p,q) = [p,q] + +-- | Swap notation to plain permutation cycles notation. +-- +-- > let n = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)] +-- > in swaps_to_cycles n == [[1],[2],[3,4],[5,6],[7,8]] +swaps_to_cycles :: [Either t (t,t)] -> [[t]] +swaps_to_cycles = map (either return pair_to_list) + +-- | One-indexed permutation cycles to zero-indexed. +-- +-- > let r = [[0],[1],[2,3],[4,5],[6,7]] +-- > in to_zero_indexed [[1],[2],[3,4],[5,6],[7,8]] == r +to_zero_indexed :: Enum t => [[t]] -> [[t]] +to_zero_indexed = map (map pred) + +-- | Apply abbreviated 'Hold' notation, given cardinality. +-- +-- > swap_abbrev 8 [3,8] [2,1,4,3,6,5,8,7] == [1,2,4,6,3,8,5,7] +swap_abbrev :: Eq a => Int -> [Int] -> [a] -> [a] +swap_abbrev k a = + let c = to_zero_indexed (swaps_to_cycles (gen_swaps k a)) + p = T.from_cycles c + in T.apply_permutation p + +-- | Apply a 'Change'. +apply_change :: Eq a => Int -> Change -> [a] -> [a] +apply_change k p l = + case p of + Swap_All -> swap_all l + Hold q -> swap_abbrev k q l + +-- | Apply a 'Method', gives next starting sequence and the course of +-- the method. +-- +-- > let r = ([1,2,4,5,3] +-- > ,[[1,2,3,4,5],[2,1,3,4,5],[2,3,1,4,5],[3,2,4,1,5],[3,4,2,5,1] +-- > ,[4,3,2,5,1],[4,2,3,1,5],[2,4,1,3,5],[2,1,4,3,5],[1,2,4,3,5]]) +-- > in apply_method cambridgeshire_slow_course_doubles [1..5] == r +apply_method :: Eq a => Method -> [a] -> ([a],[[a]]) +apply_method m l = + let k = length l + f z e = (apply_change k e z,z) + in mapAccumL f l (method_changes m) + +-- | Iteratively apply a 'Method' until it closes (ie. arrives back at +-- the starting sequence). +-- +-- > length (closed_method cambridgeshire_slow_course_doubles [1..5]) == 3 +closed_method :: Eq a => Method -> [a] -> [[[a]]] +closed_method m l = + let rec c r = + let (e,z) = apply_method m c + in if e == l + then reverse (z : r) + else rec e (z : r) + in rec l [] + +-- | 'concat' of 'closed_method' with initial sequence appended. +closed_method' :: Eq a => Method -> [a] -> [[a]] +closed_method' m l = concat (closed_method m l) ++ [l] + +-- * Methods + +-- | Cambridgeshire Slow Course Doubles. +-- +-- +-- +-- > length (closed_method cambridgeshire_slow_course_doubles [1..5]) == 3 +cambridgeshire_slow_course_doubles :: Method +cambridgeshire_slow_course_doubles = + let a = ("345.145.5.1.345",Just "123") + in parse_method a + +-- | Double Cambridge Cyclic Bob Minor. +-- +-- +-- +-- > length (closed_method double_cambridge_cyclic_bob_minor [1..6]) == 5 +double_cambridge_cyclic_bob_minor :: Method +double_cambridge_cyclic_bob_minor = + let a = ("-14-16-56-36-16-12",Nothing) + in parse_method a + +-- | Hammersmith Bob Triples +-- +-- +-- +-- > length (closed_method hammersmith_bob_triples [1..7]) == 6 +hammersmith_bob_triples :: Method +hammersmith_bob_triples = + let a = ("7.1.5.123.7.345.7",Just "127") + in parse_method a + +-- | Cambridge Surprise Major. +-- +-- +-- +-- > length (closed_method cambridge_surprise_major [1..8]) == 7 +cambridge_surprise_major :: Method +cambridge_surprise_major = + let a = ("-38-14-1258-36-14-58-16-78",Just "12") + in parse_method a + +-- | Smithsonian Surprise Royal. +-- +-- +-- +-- > length (closed_method smithsonian_surprise_royal [1..10]) == 9 +smithsonian_surprise_royal :: Method +smithsonian_surprise_royal = + let a = ("-3A-14-5A-16-347A-18-1456-5A-16-7A",Just "12") + in parse_method a diff --git a/Music/Theory/Pitch.hs b/Music/Theory/Pitch.hs --- a/Music/Theory/Pitch.hs +++ b/Music/Theory/Pitch.hs @@ -1,32 +1,25 @@ -- | Common music notation pitch values. module Music.Theory.Pitch where -import Data.Char -import Data.Function -import Data.Maybe +import Data.Char {- base -} +import Data.Function {- base -} +import Data.List {- base -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Math as T {- hmt -} +import Music.Theory.Pitch.Note {- hmt -} +import Music.Theory.Pitch.Spelling {- hmt -} + -- | Pitch classes are modulo twelve integers. -type PitchClass = Integer +type PitchClass = Int --- | Octaves are 'Integer's, the octave of middle C is @4@. -type Octave = Integer +-- | Octaves are integers, the octave of middle C is @4@. +type Octave = Int -- | 'Octave' and 'PitchClass' duple. type Octave_PitchClass i = (i,i) type OctPC = (Octave,PitchClass) --- | 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) - --- | 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) - -- | Common music notation pitch value. data Pitch = Pitch {note :: Note_T ,alteration :: Alteration_T @@ -36,164 +29,17 @@ instance Ord Pitch where compare = pitch_compare --- | Pretty printer for 'Pitch' (unicode, see 'alteration_symbol'). --- --- > pitch_pp (Pitch E Flat 4) == "E♭4" --- > pitch_pp (Pitch F QuarterToneSharp 3) == "F𝄲3" -pitch_pp :: Pitch -> String -pitch_pp (Pitch n a o) = - let a' = if a == Natural then "" else [alteration_symbol a] - in show n ++ a' ++ show o - --- | Pretty printer for 'Pitch' (ASCII, see 'alteration_ly_name'). --- --- > pitch_pp_ascii (Pitch E Flat 4) == "ees4" --- > pitch_pp_ascii (Pitch F QuarterToneSharp 3) == "fih3" -pitch_pp_ascii :: Pitch -> String -pitch_pp_ascii (Pitch n a o) = - let n' = map toLower (show n) - in n' ++ alteration_ly_name a ++ show o - --- | 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 - --- | Transform 'Alteration_T' to semitone alteration. Returns --- 'Nothing' for non-semitone alterations. --- --- > map alteration_to_diff [Flat,QuarterToneSharp] == [Just (-1),Nothing] -alteration_to_diff :: Integral i => Alteration_T -> Maybe i -alteration_to_diff a = - case a of - DoubleFlat -> Just (-2) - Flat -> Just (-1) - Natural -> Just 0 - Sharp -> Just 1 - DoubleSharp -> Just 2 - _ -> Nothing - --- | Transform 'Alteration_T' to semitone alteration. --- --- > map alteration_to_diff_err [Flat,Sharp] == [-1,1] -alteration_to_diff_err :: Integral i => Alteration_T -> i -alteration_to_diff_err = - let err = error "alteration_to_diff: quarter tone" - in fromMaybe err . alteration_to_diff - --- | Transform 'Alteration_T' to fractional semitone alteration, --- ie. allow quarter tones. --- --- > alteration_to_fdiff QuarterToneSharp == 0.5 -alteration_to_fdiff :: Fractional n => Alteration_T -> n -alteration_to_fdiff a = - case a of - ThreeQuarterToneFlat -> -1.5 - QuarterToneFlat -> -0.5 - QuarterToneSharp -> 0.5 - ThreeQuarterToneSharp -> 1.5 - _ -> fromInteger (alteration_to_diff_err a) - --- | Transform fractional semitone alteration to 'Alteration_T', --- ie. allow quarter tones. --- --- > map fdiff_to_alteration [-0.5,0.5] == [Just QuarterToneFlat --- > ,Just QuarterToneSharp] -fdiff_to_alteration :: (Fractional n,Eq n) => n -> Maybe Alteration_T -fdiff_to_alteration d = - case d of - -2 -> Just DoubleFlat - -1.5 -> Just ThreeQuarterToneFlat - -1 -> Just Flat - -0.5 -> Just QuarterToneFlat - 0 -> Just Natural - 0.5 -> Just QuarterToneSharp - 1 -> Just Sharp - 1.5 -> Just ThreeQuarterToneSharp - 2 -> Just DoubleSharp - _ -> undefined - --- | Unicode has entries for /Musical Symbols/ in the range @U+1D100@ --- through @U+1D1FF@. The @3/4@ symbols are non-standard, here they --- correspond to @MUSICAL SYMBOL FLAT DOWN@ and @MUSICAL SYMBOL SHARP --- UP@. --- --- > map alteration_symbol [minBound .. maxBound] == "𝄫𝄭♭𝄳♮𝄲♯𝄰𝄪" -alteration_symbol :: Alteration_T -> Char -alteration_symbol a = case a of - DoubleFlat -> '𝄫' - ThreeQuarterToneFlat -> '𝄭' - Flat -> '♭' - QuarterToneFlat -> '𝄳' - Natural -> '♮' - QuarterToneSharp -> '𝄲' - Sharp -> '♯' - ThreeQuarterToneSharp -> '𝄰' - DoubleSharp -> '𝄪' - --- | The @Lilypond@ ASCII spellings for alterations. --- --- > map alteration_ly_name [Flat .. Sharp] == ["es","eh","","ih","is"] -alteration_ly_name :: Alteration_T -> String -alteration_ly_name a = - case a of - DoubleFlat -> "eses" - ThreeQuarterToneFlat -> "eseh" - Flat -> "es" - QuarterToneFlat -> "eh" - Natural -> "" - QuarterToneSharp -> "ih" - Sharp -> "is" - ThreeQuarterToneSharp -> "isih" - DoubleSharp -> "isis" - --- | Raise 'Alteration_T' by a quarter tone where possible. --- --- > alteration_raise_quarter_tone Flat == Just QuarterToneFlat --- > alteration_raise_quarter_tone DoubleSharp == Nothing -alteration_raise_quarter_tone :: Alteration_T -> Maybe Alteration_T -alteration_raise_quarter_tone a = - if a == maxBound then Nothing else Just (toEnum (fromEnum a + 1)) - --- | Lower 'Alteration_T' by a quarter tone where possible. --- --- > alteration_lower_quarter_tone Sharp == Just QuarterToneSharp --- > alteration_lower_quarter_tone DoubleFlat == Nothing -alteration_lower_quarter_tone :: Alteration_T -> Maybe Alteration_T -alteration_lower_quarter_tone a = - if a == minBound then Nothing else Just (toEnum (fromEnum a - 1)) +-- | Generalised pitch, given by a generalised alteration. +data Pitch' = Pitch' Note_T Alteration_T' Octave + deriving (Eq,Show) --- | Edit 'Alteration_T' by a quarter tone where possible, @-0.5@ --- lowers, @0@ retains, @0.5@ raises. -alteration_edit_quarter_tone :: (Fractional n,Eq n) => - n -> Alteration_T -> Maybe Alteration_T -alteration_edit_quarter_tone n a = - case n of - -0.5 -> alteration_lower_quarter_tone a - 0 -> Just a - 0.5 -> alteration_raise_quarter_tone a - _ -> Nothing +-- | Pretty printer for 'Pitch''. +pitch'_pp :: Pitch' -> String +pitch'_pp (Pitch' n (_,a) o) = show n ++ a ++ show o --- | Simplify 'Alteration_T' to standard 12ET by deleting quarter tones. --- --- > Data.List.nub (map alteration_clear_quarter_tone [minBound..maxBound]) -alteration_clear_quarter_tone :: Alteration_T -> Alteration_T -alteration_clear_quarter_tone x = - case x of - ThreeQuarterToneFlat -> Flat - QuarterToneFlat -> Flat - QuarterToneSharp -> Sharp - ThreeQuarterToneSharp -> Sharp - _ -> x +-- | '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. -- @@ -210,6 +56,10 @@ pitch_to_octpc :: Integral i => Pitch -> Octave_PitchClass i pitch_to_octpc = midi_to_octpc . pitch_to_midi +-- | Is 'Pitch' 12-ET. +pitch_is_12et :: Pitch -> Bool +pitch_is_12et = alteration_is_12et . alteration + -- | 'Pitch' to midi note number notation. -- -- > pitch_to_midi (Pitch A Natural 4) == 69 @@ -223,10 +73,10 @@ -- | 'Pitch' to fractional midi note number notation. -- -- > pitch_to_fmidi (Pitch A QuarterToneSharp 4) == 69.5 -pitch_to_fmidi :: Pitch -> Double +pitch_to_fmidi :: Fractional n => Pitch -> n pitch_to_fmidi (Pitch n a o) = let a' = alteration_to_fdiff a - o' = fromInteger o + o' = fromIntegral o n' = fromInteger (note_to_pc n) in 12 + o' * 12 + n' + a' @@ -241,10 +91,9 @@ -- -- > pitch_compare (Pitch A Natural 4) (Pitch A QuarterToneSharp 4) == LT pitch_compare :: Pitch -> Pitch -> Ordering -pitch_compare = compare `on` pitch_to_fmidi - --- | Function to spell a 'PitchClass'. -type Spelling n = n -> (Note_T,Alteration_T) +pitch_compare = + let f = pitch_to_fmidi :: Pitch -> Double + in compare `on` f -- | Given 'Spelling' function translate from 'OctPC' notation to -- 'Pitch'. @@ -281,12 +130,24 @@ octpc_to_midi :: Integral i => Octave_PitchClass i -> i octpc_to_midi (o,pc) = 60 + ((fromIntegral o - 4) * 12) + pc +-- | 'fromIntegral' of 'octpc_to_midi'. +octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n +octpc_to_fmidi = fromIntegral . octpc_to_midi + -- | Inverse of 'octpc_to_midi'. -- -- > midi_to_octpc 69 == (4,9) midi_to_octpc :: Integral i => i -> Octave_PitchClass i midi_to_octpc n = (n - 12) `divMod` 12 +-- | Enumerate range, inclusive. +-- +-- > octpc_range ((3,8),(4,1)) == [(3,8),(3,9),(3,10),(3,11),(4,0),(4,1)] +octpc_range :: (OctPC,OctPC) -> [OctPC] +octpc_range (l,r) = + let (l',r') = (octpc_to_midi l,octpc_to_midi r) + in map midi_to_octpc [l' .. r'] + -- | Midi note number to 'Pitch'. -- -- > let r = ["C4","E♭4","F♯4"] @@ -301,13 +162,42 @@ -- > 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 Integer -> n -> Pitch +fmidi_to_pitch :: RealFrac n => Spelling Int -> n -> Pitch fmidi_to_pitch sp m = let m' = round m (Pitch n a o) = midi_to_pitch sp m' - Just a' = alteration_edit_quarter_tone (m - fromIntegral m') a - in Pitch n a' o + q = m - fromIntegral m' + in case alteration_edit_quarter_tone q a of + Nothing -> error "fmidi_to_pitch" + Just a' -> Pitch n a' o +-- | Composition of 'pitch_to_fmidi' and then 'fmidi_to_pitch'. +-- +-- > import Music.Theory.Pitch.Name as T +-- > import Music.Theory.Pitch.Spelling as T +-- +-- > pitch_tranpose T.pc_spell_ks 2 T.ees5 == T.f5 +pitch_tranpose :: RealFrac n => Spelling Int -> n -> Pitch -> Pitch +pitch_tranpose sp n p = + let m = pitch_to_fmidi p + in fmidi_to_pitch sp (m + n) + +-- | Set octave of /p2/ so that it nearest to /p1/. +-- +-- > import Music.Theory.Pitch.Name as T +-- +-- > let {r = ["B1","C2","C#2"];f = pitch_in_octave_nearest T.cis2} +-- > in map (pitch_pp_iso . f) [T.b4,T.c4,T.cis4] == r +pitch_in_octave_nearest :: Pitch -> Pitch -> Pitch +pitch_in_octave_nearest p1 p2 = + let o1 = octave p1 + p2' = map (\n -> p2 {octave = n}) [o1 - 1,o1,o1 + 1] + m1 = pitch_to_fmidi p1 :: Double + m2 = map (pitch_to_fmidi) p2' + d = map (abs . (m1 -)) m2 + z = sortBy (compare `on` snd) (zip p2' d) + in fst (head z) + -- | Raise 'Note_T' of 'Pitch', account for octave transposition. -- -- > pitch_note_raise (Pitch B Natural 3) == Pitch C Natural 4 @@ -342,18 +232,9 @@ -- | Apply function to 'octave' of 'PitchClass'. -- -- > pitch_edit_octave (+ 1) (Pitch A Natural 4) == Pitch A Natural 5 -pitch_edit_octave :: (Integer -> Integer) -> Pitch -> Pitch +pitch_edit_octave :: (Octave -> Octave) -> Pitch -> Pitch pitch_edit_octave f (Pitch n a o) = Pitch n a (f o) --- | Modal transposition of 'Note_T' value. --- --- > note_t_transpose C 2 == E -note_t_transpose :: Note_T -> Int -> Note_T -note_t_transpose x n = - let x' = fromEnum x - n' = fromEnum (maxBound::Note_T) + 1 - in toEnum ((x' + n) `mod` n') - -- * Frequency (CPS) -- | /Midi/ note number to cycles per second. @@ -368,7 +249,12 @@ fmidi_to_cps :: Floating a => a -> a fmidi_to_cps i = 440 * (2 ** ((i - 69) * (1 / 12))) --- | Frequency (cycles per second) to /midi/ note number. +-- | 'fmidi_to_cps' of 'pitch_to_fmidi'. +pitch_to_cps :: Floating n => Pitch -> n +pitch_to_cps = fmidi_to_cps . pitch_to_fmidi + +-- | Frequency (cycles per second) to /midi/ note number, ie. 'round' +-- of 'cps_to_fmidi'. -- -- > map cps_to_midi [261.6,440] == [60,69] cps_to_midi :: (Integral i,Floating f,RealFrac f) => f -> i @@ -381,8 +267,119 @@ cps_to_fmidi :: Floating a => a -> a cps_to_fmidi a = (logBase 2 (a * (1 / 440)) * 12) + 69 +-- | Midi note number with cents detune. +type Midi_Detune = (Int,Double) + +-- | Frequency (in hertz) to 'Midi_Detune'. +-- +-- > map (fmap round . cps_to_midi_detune) [440.00,508.35] == [(69,0),(71,50)] +cps_to_midi_detune :: Double -> Midi_Detune +cps_to_midi_detune f = + let (n,c) = T.integral_and_fractional_parts (cps_to_fmidi f) + in (n,c * 100) + +-- | Inverse of 'cps_to_midi_detune'. +midi_detune_to_cps :: Midi_Detune -> Double +midi_detune_to_cps (m,c) = fmidi_to_cps (fromIntegral m + (c / 100)) + -- | 'midi_to_cps' of 'octpc_to_midi'. -- -- > octpc_to_cps (4,9) == 440 octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n octpc_to_cps = midi_to_cps . octpc_to_midi + +-- | 'midi_to_octpc' of 'cps_to_midi'. +cps_to_octpc :: (Floating f,RealFrac f,Integral i) => f -> Octave_PitchClass i +cps_to_octpc = midi_to_octpc . cps_to_midi + +-- * Parsers + +-- | Slight generalisation of ISO pitch representation. Allows octave +-- to be elided, pitch names to be lower case, and double sharps +-- written as @##@. +-- +-- See +-- +-- > let r = [Pitch C Natural 4,Pitch A Flat 5,Pitch F DoubleSharp 6] +-- > in mapMaybe (parse_iso_pitch_oct 4) ["C","Ab5","f##6",""] == r +parse_iso_pitch_oct :: Octave -> String -> Maybe Pitch +parse_iso_pitch_oct def_o s = + let nte n = let tb = zip "cdefgab" [C,D,E,F,G,A,B] + in lookup (toLower n) tb + oct o = case o of + [] -> Just def_o + [n] -> if isDigit n + then Just (fromIntegral (digitToInt n)) + else Nothing + _ -> Nothing + mk n a o = case nte n of + Nothing -> Nothing + Just n' -> fmap (Pitch n' a) (oct o) + in case s of + [] -> Nothing + n:'b':'b':o -> mk n DoubleFlat o + n:'#':'#':o -> mk n DoubleSharp o + n:'x':o -> mk n DoubleSharp o + n:'b':o -> mk n Flat o + n:'#':o -> mk n Sharp o + n:o -> mk n Natural o + +-- | Variant of 'parse_iso_pitch_oct' requiring octave. +parse_iso_pitch :: String -> Maybe Pitch +parse_iso_pitch = parse_iso_pitch_oct (error "parse_iso_pitch: no octave") + +-- * Pretty printers + +-- | Pretty printer for 'Pitch' (unicode, see 'alteration_symbol'). +-- +-- > pitch_pp (Pitch E Flat 4) == "E♭4" +-- > pitch_pp (Pitch F QuarterToneSharp 3) == "F𝄲3" +pitch_pp :: Pitch -> String +pitch_pp (Pitch n a o) = + let a' = if a == Natural then "" else [alteration_symbol a] + in show n ++ a' ++ show o + +-- | 'Pitch' printed without octave. +pitch_class_pp :: Pitch -> String +pitch_class_pp = T.dropWhileRight isDigit . pitch_pp + +-- | Sequential list of /n/ pitch class names starting from /k/. +-- +-- > pitch_class_names_12et 11 2 == ["B","C"] +pitch_class_names_12et :: Integral n => n -> n -> [String] +pitch_class_names_12et k n = + let f = pitch_class_pp . midi_to_pitch pc_spell_ks + in map f [60 + k .. 60 + k + n - 1] + +-- | Pretty printer for 'Pitch' (ISO, ASCII, see 'alteration_iso'). +-- +-- > pitch_pp_iso (Pitch E Flat 4) == "Eb4" +-- > pitch_pp_iso (Pitch F DoubleSharp 3) == "Fx3" +pitch_pp_iso :: Pitch -> String +pitch_pp_iso (Pitch n a o) = show n ++ alteration_iso a ++ show o + +-- | Pretty printer for 'Pitch' (ASCII, see 'alteration_tonh'). +-- +-- > pitch_pp_hly (Pitch E Flat 4) == "ees4" +-- > pitch_pp_hly (Pitch F QuarterToneSharp 3) == "fih3" +-- > pitch_pp_hly (Pitch B Natural 6) == "b6" +pitch_pp_hly :: Pitch -> String +pitch_pp_hly (Pitch n a o) = + let n' = map toLower (show n) + in n' ++ alteration_tonh a ++ show o + +-- | Pretty printer for 'Pitch' (Tonhöhe, see 'alteration_tonh'). +-- +-- > pitch_pp_tonh (Pitch E Flat 4) == "Es4" +-- > pitch_pp_tonh (Pitch F QuarterToneSharp 3) == "Fih3" +-- > pitch_pp_tonh (Pitch B Natural 6) == "H6" +pitch_pp_tonh :: Pitch -> String +pitch_pp_tonh (Pitch n a o) = + let o' = show o + in case (n,a) of + (B,Natural) -> "H" ++ o' + (B,Flat) -> "B" ++ o' + (B,DoubleFlat) -> "Heses" ++ o' + (A,Flat) -> "As" ++ o' + (E,Flat) -> "Es" ++ o' + _ -> show n ++ alteration_tonh a ++ o' diff --git a/Music/Theory/Pitch/Name.hs b/Music/Theory/Pitch/Name.hs --- a/Music/Theory/Pitch/Name.hs +++ b/Music/Theory/Pitch/Name.hs @@ -5,6 +5,7 @@ module Music.Theory.Pitch.Name where import Music.Theory.Pitch +import Music.Theory.Pitch.Note a0,b0 :: Pitch a0 = Pitch A Natural 0 @@ -79,6 +80,42 @@ gisis2 = Pitch G DoubleSharp 2 aisis2 = Pitch A DoubleSharp 2 bisis2 = Pitch B DoubleSharp 2 + +ceseh2,deseh2,eeseh2,feseh2,geseh2,aeseh2,beseh2 :: Pitch +ceseh2 = Pitch C ThreeQuarterToneFlat 2 +deseh2 = Pitch D ThreeQuarterToneFlat 2 +eeseh2 = Pitch E ThreeQuarterToneFlat 2 +feseh2 = Pitch F ThreeQuarterToneFlat 2 +geseh2 = Pitch G ThreeQuarterToneFlat 2 +aeseh2 = Pitch A ThreeQuarterToneFlat 2 +beseh2 = Pitch B ThreeQuarterToneFlat 2 + +ceh2,deh2,eeh2,feh2,geh2,aeh2,beh2 :: Pitch +ceh2 = Pitch C QuarterToneFlat 2 +deh2 = Pitch D QuarterToneFlat 2 +eeh2 = Pitch E QuarterToneFlat 2 +feh2 = Pitch F QuarterToneFlat 2 +geh2 = Pitch G QuarterToneFlat 2 +aeh2 = Pitch A QuarterToneFlat 2 +beh2 = Pitch B QuarterToneFlat 2 + +cih2,dih2,eih2,fih2,gih2,aih2,bih2 :: Pitch +cih2 = Pitch C QuarterToneSharp 2 +dih2 = Pitch D QuarterToneSharp 2 +eih2 = Pitch E QuarterToneSharp 2 +fih2 = Pitch F QuarterToneSharp 2 +gih2 = Pitch G QuarterToneSharp 2 +aih2 = Pitch A QuarterToneSharp 2 +bih2 = Pitch B QuarterToneSharp 2 + +cisih2,disih2,eisih2,fisih2,gisih2,aisih2,bisih2 :: Pitch +cisih2 = Pitch C ThreeQuarterToneSharp 2 +disih2 = Pitch D ThreeQuarterToneSharp 2 +eisih2 = Pitch E ThreeQuarterToneSharp 2 +fisih2 = Pitch F ThreeQuarterToneSharp 2 +gisih2 = Pitch G ThreeQuarterToneSharp 2 +aisih2 = Pitch A ThreeQuarterToneSharp 2 +bisih2 = Pitch B ThreeQuarterToneSharp 2 c3,d3,e3,f3,g3,a3,b3 :: Pitch c3 = Pitch C Natural 3 diff --git a/Music/Theory/Pitch/Note.hs b/Music/Theory/Pitch/Note.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Note.hs @@ -0,0 +1,224 @@ +-- | Common music notation note and alteration values. +module Music.Theory.Pitch.Note where + +import Data.Maybe {- base -} + +-- * Note + +-- | Enumeration of common music notation note names (@C@ to @B@). +data Note_T = C | D | E | F | G | A | B + deriving (Eq,Enum,Bounded,Ord,Show) + +-- | Transform 'Note_T' to pitch-class number. +-- +-- > map note_to_pc [C,E,G] == [0,4,7] +note_to_pc :: Integral i => Note_T -> i +note_to_pc n = + case n of + C -> 0 + D -> 2 + E -> 4 + F -> 5 + G -> 7 + A -> 9 + B -> 11 + +-- | Modal transposition of 'Note_T' value. +-- +-- > note_t_transpose C 2 == E +note_t_transpose :: Note_T -> Int -> Note_T +note_t_transpose x n = + let x' = fromEnum x + n' = fromEnum (maxBound::Note_T) + 1 + in toEnum ((x' + n) `mod` n') + +-- * Alteration + +-- | Enumeration of common music notation note alterations. +data Alteration_T = DoubleFlat + | ThreeQuarterToneFlat | Flat | QuarterToneFlat + | Natural + | QuarterToneSharp | Sharp | ThreeQuarterToneSharp + | DoubleSharp + deriving (Eq,Enum,Bounded,Ord,Show) + +-- | Generic form. +generic_alteration_to_diff :: Integral i => Alteration_T -> Maybe i +generic_alteration_to_diff a = + case a of + DoubleFlat -> Just (-2) + Flat -> Just (-1) + Natural -> Just 0 + Sharp -> Just 1 + DoubleSharp -> Just 2 + _ -> Nothing + +-- | Transform 'Alteration_T' to semitone alteration. Returns +-- 'Nothing' for non-semitone alterations. +-- +-- > map alteration_to_diff [Flat,QuarterToneSharp] == [Just (-1),Nothing] +alteration_to_diff :: Alteration_T -> Maybe Int +alteration_to_diff = generic_alteration_to_diff + +-- | Is 'Alteration_T' 12-ET. +alteration_is_12et :: Alteration_T -> Bool +alteration_is_12et = isJust . alteration_to_diff + +-- | Transform 'Alteration_T' to semitone alteration. +-- +-- > map alteration_to_diff_err [Flat,Sharp] == [-1,1] +alteration_to_diff_err :: Integral i => Alteration_T -> i +alteration_to_diff_err = + let err = error "alteration_to_diff: quarter tone" + in fromMaybe err . generic_alteration_to_diff + +-- | Transform 'Alteration_T' to fractional semitone alteration, +-- ie. allow quarter tones. +-- +-- > alteration_to_fdiff QuarterToneSharp == 0.5 +alteration_to_fdiff :: Fractional n => Alteration_T -> n +alteration_to_fdiff a = + case a of + ThreeQuarterToneFlat -> -1.5 + QuarterToneFlat -> -0.5 + QuarterToneSharp -> 0.5 + ThreeQuarterToneSharp -> 1.5 + _ -> fromInteger (alteration_to_diff_err a) + +-- | Transform fractional semitone alteration to 'Alteration_T', +-- ie. allow quarter tones. +-- +-- > map fdiff_to_alteration [-0.5,0.5] == [Just QuarterToneFlat +-- > ,Just QuarterToneSharp] +fdiff_to_alteration :: (Fractional n,Eq n) => n -> Maybe Alteration_T +fdiff_to_alteration d = + case d of + -2 -> Just DoubleFlat + -1.5 -> Just ThreeQuarterToneFlat + -1 -> Just Flat + -0.5 -> Just QuarterToneFlat + 0 -> Just Natural + 0.5 -> Just QuarterToneSharp + 1 -> Just Sharp + 1.5 -> Just ThreeQuarterToneSharp + 2 -> Just DoubleSharp + _ -> undefined + +-- | Raise 'Alteration_T' by a quarter tone where possible. +-- +-- > alteration_raise_quarter_tone Flat == Just QuarterToneFlat +-- > alteration_raise_quarter_tone DoubleSharp == Nothing +alteration_raise_quarter_tone :: Alteration_T -> Maybe Alteration_T +alteration_raise_quarter_tone a = + if a == maxBound then Nothing else Just (toEnum (fromEnum a + 1)) + +-- | Lower 'Alteration_T' by a quarter tone where possible. +-- +-- > alteration_lower_quarter_tone Sharp == Just QuarterToneSharp +-- > alteration_lower_quarter_tone DoubleFlat == Nothing +alteration_lower_quarter_tone :: Alteration_T -> Maybe Alteration_T +alteration_lower_quarter_tone a = + if a == minBound then Nothing else Just (toEnum (fromEnum a - 1)) + +-- | Edit 'Alteration_T' by a quarter tone where possible, @-0.5@ +-- lowers, @0@ retains, @0.5@ raises. +-- +-- > import Data.Ratio +-- > alteration_edit_quarter_tone (-1 % 2) Flat == Just ThreeQuarterToneFlat +alteration_edit_quarter_tone :: (Fractional n,Eq n) => + n -> Alteration_T -> Maybe Alteration_T +alteration_edit_quarter_tone n a = + case n of + -0.5 -> alteration_lower_quarter_tone a + 0 -> Just a + 0.5 -> alteration_raise_quarter_tone a + _ -> Nothing + +-- | Simplify 'Alteration_T' to standard 12ET by deleting quarter tones. +-- +-- > Data.List.nub (map alteration_clear_quarter_tone [minBound..maxBound]) +alteration_clear_quarter_tone :: Alteration_T -> Alteration_T +alteration_clear_quarter_tone x = + case x of + ThreeQuarterToneFlat -> Flat + QuarterToneFlat -> Flat + QuarterToneSharp -> Sharp + ThreeQuarterToneSharp -> Sharp + _ -> x + +-- | Unicode has entries for /Musical Symbols/ in the range @U+1D100@ +-- through @U+1D1FF@. The @3/4@ symbols are non-standard, here they +-- correspond to @MUSICAL SYMBOL FLAT DOWN@ and @MUSICAL SYMBOL SHARP +-- UP@. +-- +-- > map alteration_symbol [minBound .. maxBound] == "𝄫𝄭♭𝄳♮𝄲♯𝄰𝄪" +alteration_symbol :: Alteration_T -> Char +alteration_symbol a = case a of + DoubleFlat -> '𝄫' + ThreeQuarterToneFlat -> '𝄭' + Flat -> '♭' + QuarterToneFlat -> '𝄳' + Natural -> '♮' + QuarterToneSharp -> '𝄲' + Sharp -> '♯' + ThreeQuarterToneSharp -> '𝄰' + DoubleSharp -> '𝄪' + +-- | The @ISO@ ASCII spellings for alterations. Naturals as written +-- as the empty string. +-- +-- > mapMaybe alteration_iso_m [Flat .. Sharp] == ["b","","#"] +alteration_iso_m :: Alteration_T -> Maybe String +alteration_iso_m a = + case a of + DoubleFlat -> Just "bb" + ThreeQuarterToneFlat -> Nothing + Flat -> Just "b" + QuarterToneFlat -> Nothing + Natural -> Just "" + QuarterToneSharp -> Nothing + Sharp -> Just "#" + ThreeQuarterToneSharp -> Nothing + DoubleSharp -> Just "x" + +-- | The @ISO@ ASCII spellings for alterations. +alteration_iso :: Alteration_T -> String +alteration_iso = + let qt = error "alteration_iso: quarter tone" + in fromMaybe qt . alteration_iso_m + +-- | The /Tonhöhe/ ASCII spellings for alterations. +-- +-- See and +-- +-- +-- > map alteration_tonh [Flat .. Sharp] == ["es","eh","","ih","is"] +alteration_tonh :: Alteration_T -> String +alteration_tonh a = + case a of + DoubleFlat -> "eses" + ThreeQuarterToneFlat -> "eseh" + Flat -> "es" + QuarterToneFlat -> "eh" + Natural -> "" + QuarterToneSharp -> "ih" + Sharp -> "is" + ThreeQuarterToneSharp -> "isih" + DoubleSharp -> "isis" + +-- * Generalised Alteration + +-- | Generalised alteration, given as a rational semitone difference +-- and a string representation of the alteration. +type Alteration_T' = (Rational,String) + +-- | Transform 'Alteration_T' to 'Alteration_T''. +-- +-- > let r = [(-1,"♭"),(0,"♮"),(1,"♯")] +-- > in map alteration_t' [Flat,Natural,Sharp] == r +alteration_t' :: Alteration_T -> Alteration_T' +alteration_t' a = (alteration_to_fdiff a,[alteration_symbol a]) + +-- | Function to spell a 'PitchClass'. +type Spelling n = n -> (Note_T,Alteration_T) + 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,7 +1,7 @@ -- | Spelling rules for common music notation. module Music.Theory.Pitch.Spelling where -import Music.Theory.Pitch +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) 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 @@ -1,6 +1,8 @@ -- | Common music notation tempo indications. module Music.Theory.Tempo_Marking where +import Data.List {- base -} + import Music.Theory.Duration import Music.Theory.Duration.RQ import Music.Theory.Time_Signature @@ -39,3 +41,45 @@ -- | 'Fractional' variant of 'measure_duration'. measure_duration_f :: Fractional c => Time_Signature -> Tempo_Marking -> c measure_duration_f ts = fromRational . measure_duration ts + +-- | Italian terms and markings from Wittner metronome (W.-Germany). +-- +metronome_table_wittner :: Num n => [(String,(n,n))] +metronome_table_wittner = + [("Largo",(40,60)) + ,("Larghetto",(60,66)) + ,("Adagio",(66,76)) + ,("Andante",(76,108)) + ,("Moderato",(108,120)) + ,("Allegro",(120,168)) + ,("Presto",(168,208))] + +-- | Italian terms and markings from Nikko Seiki metronome (Japan). +-- +metronome_table_nikko :: Num n => [(String,(n,n))] +metronome_table_nikko = + [("Grave",(40,46)) + ,("Largo",(46,52)) + ,("Lento",(52,56)) + ,("Adagio",(56,60)) + ,("Larghetto",(60,66)) + ,("Adagietto",(66,72)) + ,("Andante",(72,80)) + ,("Andantino",(80,88)) + ,("Maestoso",(88,96)) + ,("Moderato",(96,108)) + ,("Allegretto",(108,120)) + ,("Animato",(120,132)) + ,("Allegro",(132,144)) + ,("Assai",(144,160)) + ,("Vivace",(160,184)) + ,("Presto",(184,208)) + ,("Prestissimo",(208,240))] + +-- | Lookup metronome mark in table. +-- +-- > mm_name metronome_table_nikko 72 == Just "Andante" +mm_name :: (Num a, Ord a) => [(String,(a,a))] -> a -> Maybe String +mm_name tbl x = + let f (_,(p,q)) = x >= p && x < q + in fmap fst (find f tbl) diff --git a/Music/Theory/Time/Bel1990/R.hs b/Music/Theory/Time/Bel1990/R.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Time/Bel1990/R.hs @@ -0,0 +1,642 @@ +{- | /Bel(R)/ is a simplified form of the /Bel/ notation described in: + +- Bernard Bel. + \"Time and musical structures\". + /Interface (Journal of New Music Research)/ + Volume 19, Issue 2-3, 1990. + () + +- Bernard Bel. + \"Two algorithms for the instantiation of structures of musical objects\". + Centre National de la Recherche Scientifique, 1992. /GRTC 458/ + () + +For patterns without tempo indications, the two notations should give +equivalent phase diagrams, for instance (Bel 1990, §11, p.24): + +> > bel_ascii_pp "ab{ab,cde}cd" +> +> Bel(R): "ab{ab,cde}cd", Dur: 7 +> +> a _ b _ a _ _ b _ _ c _ d _ +> c _ d _ e _ + +and: + +> > bel_ascii_pp "{a{bc,def},ghijk}" +> +> Bel(R): "{a{bc,def},ghijk}", Dur: 5 +> +> a _ _ _ _ _ _ _ _ _ b _ _ _ _ _ _ _ _ _ _ _ _ _ _ c _ _ _ _ _ _ _ _ _ _ _ _ _ _ +> d _ _ _ _ _ _ _ _ _ e _ _ _ _ _ _ _ _ _ f _ _ _ _ _ _ _ _ _ +> g _ _ _ _ _ _ _ h _ _ _ _ _ _ _ i _ _ _ _ _ _ _ j _ _ _ _ _ _ _ k _ _ _ _ _ _ _ + +The /Bel/ notation allows /n/-ary parallel structures, +ie. @{a_bcd_e,a_f_gh_,ji_a_i_}@ (Bel 1992, p.29), however /Bel(R)/ +allows only binary structures. The parallel interpretation rules are +associative: + +> > bel_ascii_pp "{a_bcd_e,{a_f_gh_,ji_a_i_}}" +> +> Bel(R): "{a_bcd_e,{a_f_gh_,ji_a_i_}}", Dur: 7 +> +> a _ b c d _ e +> a _ f _ g h _ +> j i _ a _ i _ + +/Bel(R)/ does allow unary parallel structures (see 'Iso'), which can +be used to /isolate/ tempo changes: + +> > bel_ascii_pp "ab{*2cd}ef{*2/3gh}ij" +> +> Bel(R): "ab{*2cd}ef{*2/3gh}ij", Dur: 10 +> +> a _ b _ c d e _ f _ g _ _ h _ _ i _ j _ + +Patterns with tempo indications have completely different meanings in +/Bel/ and /Bel(R)/, though in both cases parallel nodes delimit the +scope of tempo markings. + +/Bel(R)/ replaces the @\/n@ notation for explicit tempo marks with a +@*n@ notation to indicate a tempo multiplier, and a set of bracketing +notations to specify interpretation rules for parallel (concurrent) +temporal structures. + +The tempo indication @\/1@ in the expression @ab{\/1ab,cde}cd@ +(Bel 1990, p.24) requires that the inner @ab@ have the same tempo as +the outer @ab@, which is implicitly @\/1@. Setting the tempo of one +part of a parallel structure requires assigning a tempo to the other +part in order that the two parts have equal duration. Here the tempo +assigned to @cde@ is @\/1.5@, but since fractional tempi are not +allowed the expression is re-written as @\/2ab{\/2ab,\/3cde}\/2cd@. + +Importantly the explicit tempo indications make it possible to write +syntactically correct expressions in /Bel/ that do not have a coherent +interpretation, ie. @{\/1ab,\/1cde}@. Determining if a coherent set +of tempos can be assigned, and assigning these tempos, is the object +of the interpretation system. + +In comparison, all syntactically valid /Bel(R)/ strings have an +interpretation. The expression @{*1ab,*1cde}@ is trivially equal to +@{ab,cde}@, and tempo marks in parallel parts do not interact: + +> > bel_ascii_pp "{a*2b,*3c/2d/3e}" +> +> Bel(R): "{a*2b,*3c*1/2d*1/3e}", Dur: 3 +> +> a _ _ _ _ _ b _ _ +> c d _ e _ _ _ _ _ + +Here @a@ is twice the duration of @b@, and @e@ is three times the +duration of @d@, which is twice the duration of @c@ (in /Bel(R)/ @\/n@ +is equivalent to @*1\/n@). The duration of any /Bel(R)/ expression +can be calculated directly, given an initial 'Tempo': + +> bel_dur 1 (bel_char_parse "a*2b") == 3/2 +> bel_dur 1 (bel_char_parse "*3c/2d/3e") == 3 + +Therefore in the composite expression the left part is slowed by a +factor of two to align with the right part. + +The /Bel/ string @ab{\/1ab,cde}cd@ can be re-written in /Bel(R)/ as +either @ab~{ab,cde}cd@ or @ab(ab,cde)cd@. The absolute tempo +indication is replaced by notations giving alternate modes of +interpretation for the parallel structure. + +In the first case the @~@ indicates the /opposite/ of the normal rule +for parallel nodes. The normal rule is the same as for /Bel/ and is +that the duration of the whole is equal to duration of the longer of +the two parts. The @~@ inverts this so that the whole has the +duration of the shorter of the two parts, and the longer part is +scaled to have equal duration. + +In the second case the parentheses @()@ replacing the braces @{}@ +indicates that the duration of the whole is equal to the duration of +the left side, and that the right is to be scaled. Similarly, a @~@ +preceding parentheses indicates the duration of the whole should be +the duration of the right side, and the left scaled. + +> > bel_ascii_pp "ab~{ab,cde}cd" +> +> Bel(R): "ab~{ab,cde}cd", Dur: 6 +> +> a _ _ b _ _ a _ _ b _ _ c _ _ d _ _ +> c _ d _ e _ + +There is one other parallel mode that has no equivalent in /Bel/ +notation. It is a mode that does not scale either part, leaving a +/hole/ at the end of the shorter part, and is indicated by square +brackets: + +> > bel_ascii_pp "ab[ab,cde]cd" +> +> Bel(R): "ab[ab,cde]cd", Dur: 7 +> +> a b a b c d +> c d e + +The /Bel/ string @\/2abc\/3de@ (Bel 1992, p.53) can be written as +@*2abc*1/2*3de@, or equivalently as @*2abc*3/2de@: + +> > bel_ascii_pp "*2abc*3/2de" +> +> Bel(R): "*2abc*3/2de", Dur: 13/6 +> +> a _ _ b _ _ c _ _ d _ e _ + +It can also be written using the shorthand notation for rest +sequences, where an integer /n/ indicates a sequence of /n/ rests, as: + +> > bel_ascii_pp "(9,abc)(4,de)" +> +> Bel(R): "(---------,abc)(----,de)", Dur: 13 +> +> - - - - - - - - - - - - - +> a _ _ b _ _ c _ _ d _ e _ + +In the /Bel/ string @{ab{/3abc,de},fghijk}@ (Bel 1992, p.20) the tempo +indication does not change the inter-relation of the parts but rather +scales the parallel node altogether, and can be re-written in /Bel(R)/ +notation as: + +> > bel_ascii_pp "{ab*3{abc,de},fghijk}" +> +> Bel(R): "{ab*3{abc,de},fghijk}", Dur: 6 +> +> a _ _ _ _ _ b _ _ _ _ _ a _ b _ c _ +> d _ _ e _ _ +> f _ _ g _ _ h _ _ i _ _ j _ _ k _ _ + +Curiously the following example (Bel 1990, p. 24) does not correspond +to the phase diagram given: + +> > bel_ascii_pp "{i{ab,cde},jk}" +> +> Bel(R): "{i{ab,cde},jk}", Dur: 4 +> +> i _ a _ _ b _ _ +> c _ d _ e _ +> j _ _ _ k _ _ _ + +The paper assigns tempi of @\/6@ to both @i@ and @ab@, which in +/Bel(R)/ could be written: + +> > bel_ascii_pp "{i~{ab,cde},jk}" +> +> Bel(R): "{i~{ab,cde},jk}", Dur: 3 +> +> i _ _ _ _ _ a _ _ _ _ _ b _ _ _ _ _ +> c _ _ _ d _ _ _ e _ _ _ +> j _ _ _ _ _ _ _ _ k _ _ _ _ _ _ _ _ + +-} + +module Music.Theory.Time.Bel1990.R where + +import Control.Monad {- base -} +import Data.Function {- base -} +import Data.List {- base -} +import Data.Ratio {- base -} +import qualified Text.ParserCombinators.Parsec as P {- parsec -} + +import qualified Music.Theory.List as T +import qualified Music.Theory.Math as T + +-- * Bel + +-- | Types of 'Par' nodes. +data Par_Mode = Par_Left | Par_Right + | Par_Min | Par_Max + | Par_None + deriving (Eq,Show) + +-- | The different 'Par' modes are indicated by bracket types. +par_mode_brackets :: Par_Mode -> (String,String) +par_mode_brackets m = + case m of + Par_Left -> ("(",")") + Par_Right -> ("~(",")") + Par_Min -> ("~{","}") + Par_Max -> ("{","}") + Par_None -> ("[","]") + +bel_brackets_match :: (Char,Char) -> Bool +bel_brackets_match (open,close) = + case (open,close) of + ('{','}') -> True + ('(',')') -> True + ('[',']') -> True + _ -> False + +-- | Tempo is rational. The duration of a 'Term' is the reciprocal of +-- the 'Tempo' that is in place at the 'Term'. +type Tempo = Rational + +-- | Terms are the leaf nodes of the temporal structure. +data Term a = Value a + | Rest + | Continue + deriving (Eq,Show) + +-- | Recursive temporal structure. +data Bel a = Node (Term a) -- ^ Leaf node + | Iso (Bel a) -- ^ Isolate + | Seq (Bel a) (Bel a) -- ^ Sequence + | Par Par_Mode (Bel a) (Bel a) -- ^ Parallel + | Mul Tempo -- ^ Tempo multiplier + deriving (Eq,Show) + +-- | Pretty printer for 'Bel', given pretty printer for the term type. +bel_pp :: (a -> String) -> Bel a -> String +bel_pp f b = + case b of + Node Rest -> "-" + Node Continue -> "_" + Node (Value c) -> f c + Iso b' -> T.bracket_l ("{","}") (bel_pp f b') + Seq p q -> concat [bel_pp f p,bel_pp f q] + Par m p q -> + let pq = concat [bel_pp f p,",",bel_pp f q] + in T.bracket_l (par_mode_brackets m) pq + Mul n -> concat ["*",T.rational_pp n] + +-- | 'bel_pp' of 'return'. +bel_char_pp :: Bel Char -> String +bel_char_pp = bel_pp return + +-- | Analyse a Par node giving (duration,LHS-tempo-*,RHS-tempo-*). +-- +-- > par_analyse 1 Par_Left (nseq "cd") (nseq "efg") == (2,1,3/2) +-- > par_analyse 1 Par_Right (nseq "cd") (nseq "efg") == (3,2/3,1) +-- > par_analyse 1 Par_Min (nseq "cd") (nseq "efg") == (2,1,3/2) +-- > par_analyse 1 Par_Max (nseq "cd") (nseq "efg") == (3,2/3,1) +-- > par_analyse 1 Par_None (nseq "cd") (nseq "efg") == (3,1,1) +par_analyse :: Tempo -> Par_Mode -> Bel a -> Bel a -> (Rational,Rational,Rational) +par_analyse t m p q = + let (_,d_p) = bel_tdur t p + (_,d_q) = bel_tdur t q + in case m of + Par_Left -> (d_p,1,d_q / d_p) + Par_Right -> (d_q,d_p / d_q,1) + Par_Min -> let r = min d_p d_q in (r,d_p / r,d_q / r) + Par_Max -> let r = max d_p d_q in (r,d_p / r,d_q / r) + Par_None -> (max d_p d_q,1,1) + +-- | Duration element of 'par_analyse'. +par_dur :: Tempo -> Par_Mode -> Bel a -> Bel a -> Rational +par_dur t m p q = + let (d,_,_) = par_analyse t m p q + in d + +-- | Calculate final tempo and duration of 'Bel'. +bel_tdur :: Tempo -> Bel a -> (Tempo,Rational) +bel_tdur t b = + case b of + Node _ -> (t,1 / t) + Iso b' -> (t,snd (bel_tdur t b')) + Seq p q -> + let (t_p,d_p) = bel_tdur t p + (t_q,d_q) = bel_tdur t_p q + in (t_q,d_p + d_q) + Par m p q -> (t,par_dur t m p q) + Mul n -> (t * n,0) + +-- | 'snd' of 'bel_tdur'. +bel_dur :: Tempo -> Bel a -> Rational +bel_dur t = snd . bel_tdur t + +-- * Linearisation + +-- | Time point. +type Time = Rational + +-- | Voices are named as a sequence of left and right directions +-- within nested 'Par' structures. +type Voice = [Char] + +-- | Linear state. 'Time' is the start time of the term, 'Tempo' is +-- the active tempo & therefore the reciprocal of the duration, +-- 'Voice' is the part label. +type L_St = (Time,Tempo,Voice) + +-- | Linear term. +type L_Term a = (L_St,Term a) + +-- | Start time of 'L_Term'. +lterm_time :: L_Term a -> Time +lterm_time ((st,_,_),_) = st + +-- | Duration of 'L_Term' (reciprocal of tempo). +lterm_duration :: L_Term a -> Time +lterm_duration ((_,tm,_),_) = 1 / tm + +-- | End time of 'L_Term'. +lterm_end_time :: L_Term a -> Time +lterm_end_time e = lterm_time e + lterm_duration e + +-- | Linear form of 'Bel', an ascending sequence of 'L_Term'. +type L_Bel a = [L_Term a] + +-- | Linearise 'Bel' given initial 'L_St', ascending by construction. +bel_linearise :: L_St -> Bel a -> (L_Bel a,L_St) +bel_linearise l_st b = + let (st,tm,vc) = l_st + in case b of + Node e -> ([(l_st,e)],(st + 1/tm,tm,vc)) + Iso p -> + let (p',(st',_,_)) = bel_linearise l_st p + in (p',(st',tm,vc)) + Seq p q -> + let (p',l_st') = bel_linearise l_st p + (q',l_st'') = bel_linearise l_st' q + in (p' ++ q',l_st'') + Par m p q -> + let (du,p_m,q_m) = par_analyse tm m p q + (p',_) = bel_linearise (st,tm * p_m,'l':vc) p + (q',_) = bel_linearise (st,tm * q_m,'r':vc) q + in (p' `lbel_merge` q',(st + du,tm,vc)) + Mul n -> ([],(st,tm * n,vc)) + +-- | Merge two ascending 'L_Bel'. +lbel_merge :: L_Bel a -> L_Bel a -> L_Bel a +lbel_merge = T.merge_by (compare `on` lterm_time) + +-- | Set of unique 'Tempo' at 'L_Bel'. +lbel_tempi :: L_Bel a -> [Tempo] +lbel_tempi = nub . sort . map (\((_,t,_),_) -> t) + +-- | Multiply 'Tempo' by /n/, and divide 'Time' by /n/. +lbel_tempo_mul :: Rational -> L_Bel a -> L_Bel a +lbel_tempo_mul n = map (\((st,tm,vc),e) -> ((st / n,tm * n,vc),e)) + +-- | After normalisation all start times and durations are integral. +lbel_normalise :: L_Bel a -> L_Bel a +lbel_normalise b = + let t = lbel_tempi b + n = foldl1 lcm (map denominator t) % 1 + m = foldl1 lcm (map numerator (map (* n) t)) % 1 + in lbel_tempo_mul (n / m) b + +-- | All leftmost voices are re-written to the last non-left turning point. +-- +-- > map voice_normalise ["","l","ll","lll"] == replicate 4 "" +-- > voice_normalise "lllrlrl" == "rlrl" +voice_normalise :: Voice -> Voice +voice_normalise = dropWhile (== 'l') + +-- | '==' 'on' 'voice_normalise' +voice_eq :: Voice -> Voice -> Bool +voice_eq = (==) `on` voice_normalise + +-- | Unique 'Voice's at 'L_Bel'. +lbel_voices :: L_Bel a -> [Voice] +lbel_voices = + sortBy (compare `on` reverse) . + nub . + map (\((_,_,v),_) -> voice_normalise v) + +-- | The duration of 'L_Bel'. +lbel_duration :: L_Bel a -> Time +lbel_duration b = + let l = last (groupBy ((==) `on` lterm_time) b) + in maximum (map (\((st,tm,_),_) -> st + recip tm) l) + +-- | Locate an 'L_Term' that is active at the indicated 'Time' and in +-- the indicated 'Voice'. +lbel_lookup :: (Time,Voice) -> L_Bel a -> Maybe (L_Term a) +lbel_lookup (st,vc) = + let f ((st',tm,vc'),_) = (st >= st' && st < st' + (1 / tm)) && + vc `voice_eq` vc' + in find f + +-- | Calculate grid (phase diagram) for 'L_Bel'. +lbel_grid :: L_Bel a -> [[Maybe (Term a)]] +lbel_grid l = + let n = lbel_normalise l + v = lbel_voices n + d = lbel_duration n + trs st ((st',_,_),e) = if st == st' then e else Continue + get vc st = fmap (trs st) (lbel_lookup (st,vc) n) + f vc = map (get vc) [0 .. d - 1] + in map f v + +-- | 'lbel_grid' of 'bel_linearise'. +bel_grid :: Bel a -> [[Maybe (Term a)]] +bel_grid b = + let (l,_) = bel_linearise (0,1,[]) b + in lbel_grid l + +-- | /Bel/ type phase diagram for 'Bel' of 'Char'. Optionally print +-- whitespace between columns. +bel_ascii :: Bool -> Bel Char -> String +bel_ascii opt = + let f e = case e of + Nothing -> ' ' + Just Rest -> '-' + Just Continue -> '_' + Just (Value c) -> c + g = if opt then intersperse ' ' else id + in unlines . map (g . map f) . bel_grid + +-- | 'putStrLn' of 'bel_ascii'. +bel_ascii_pr :: Bel Char -> IO () +bel_ascii_pr = putStrLn . ('\n' :) . bel_ascii True + +-- * Combinators + +-- | Infix form for 'Seq'. +(~>) :: Bel a -> Bel a -> Bel a +p ~> q = Seq p q + +-- | 'foldl1' of 'Seq'. +-- +-- > lseq [Node Rest] == Node Rest +-- > lseq [Node Rest,Node Continue] == Seq (Node Rest) (Node Continue) +lseq :: [Bel a] -> Bel a +lseq = foldl1 Seq + +-- | 'Node' of 'Value'. +node :: a -> Bel a +node = Node . Value + +-- | 'lseq' of 'Node' +nseq :: [a] -> Bel a +nseq = lseq . map node + +-- | Variant of 'nseq' where @_@ is read as 'Continue' and @-@ as 'Rest'. +cseq :: String -> Bel Char +cseq = + let f c = case c of + '_' -> Continue + '-' -> Rest + _ -> Value c + in foldl1 Seq . map (Node . f) + +-- | 'Par' of 'Par_Max', this is the default 'Par_Mode'. +par :: Bel a -> Bel a -> Bel a +par = Par Par_Max + +-- | 'Node' of 'Rest'. +rest :: Bel a +rest = Node Rest + +-- | 'lseq' of 'replicate' of 'rest'. +nrests :: Integral n => n -> Bel a +nrests n = lseq (genericReplicate n rest) + +-- | Verify that 'bel_char_pp' of 'bel_char_parse' is 'id'. +bel_parse_pp_ident :: String -> Bool +bel_parse_pp_ident s = bel_char_pp (bel_char_parse s) == s + +-- | Run 'bel_char_parse', and print both 'bel_char_pp' and 'bel_ascii'. +-- +-- > bel_ascii_pp "{i{ab,{c[d,oh]e,sr{p,qr}}},{jk,ghjkj}}" +bel_ascii_pp :: String -> IO () +bel_ascii_pp s = do + let p = bel_char_parse s + putStrLn (concat ["\nBel(R): \"",bel_char_pp p,"\", Dur: ",T.rational_pp (bel_dur 1 p),""]) + bel_ascii_pr p + +-- * Parsing + +-- | A 'Char' parser. +type P a = P.GenParser Char () a + +-- | Parse 'Rest' 'Term'. +-- +-- > P.parse p_rest "" "-" +p_rest :: P (Term a) +p_rest = liftM (const Rest) (P.char '-') + +-- | Parse 'Rest' 'Term'. +-- +-- > P.parse p_nrests "" "3" +p_nrests :: P (Bel a) +p_nrests = liftM nrests p_integer + +-- | Parse 'Continue' 'Term'. +-- +-- > P.parse p_continue "" "_" +p_continue :: P (Term a) +p_continue = liftM (const Continue) (P.char '_') + +-- | Parse 'Char' 'Value' 'Term'. +-- +-- > P.parse p_char_value "" "a" +p_char_value :: P (Term Char) +p_char_value = liftM Value P.lower + +-- | Parse 'Char' 'Term'. +-- +-- > P.parse (P.many1 p_char_term) "" "-_a" +p_char_term :: P (Term Char) +p_char_term = P.choice [p_rest,p_continue,p_char_value] + +-- | Parse 'Char' 'Node'. +-- +-- > P.parse (P.many1 p_char_node) "" "-_a" +p_char_node :: P (Bel Char) +p_char_node = liftM Node p_char_term + +-- | Parse positive 'Integer'. +-- +-- > P.parse p_integer "" "3" +p_integer :: P Integer +p_integer = liftM read (P.many1 P.digit) + +-- | Parse positive 'Rational'. +-- +-- > P.parse (p_rational `P.sepBy` (P.char ',')) "" "3%5,2/3" +p_rational :: P Rational +p_rational = do + n <- p_integer + _ <- P.oneOf "%/" + d <- p_integer + return (n % d) + +-- | Parse positive 'Double'. +-- +-- > P.parse p_double "" "3.5" +-- > P.parse (p_double `P.sepBy` (P.char ',')) "" "3.5,7.2,1.0" +p_double :: P Double +p_double = do + a <- P.many1 P.digit + _ <- P.char '.' + b <- P.many1 P.digit + return (read (a ++ "." ++ b)) + +-- | Parse positive number as 'Rational'. +-- +-- > P.parse (p_number `P.sepBy` (P.char ',')) "" "7%2,3.5,3" +p_number :: P Rational +p_number = P.choice [P.try p_rational + ,P.try (liftM toRational p_double) + ,P.try (liftM toRational p_integer)] + +-- | Parse 'Mul'. +-- +-- > P.parse (P.many1 p_mul) "" "/3*3/2" +p_mul :: P (Bel a) +p_mul = do + op <- P.oneOf "*/" + n <- p_number + let n' = case op of + '*' -> n + '/' -> recip n + _ -> error "p_mul" + return (Mul n') + +-- | Given parser for 'Bel' /a/, generate 'Iso' parser. +p_iso :: P (Bel a) -> P (Bel a) +p_iso f = do + open <- P.oneOf "{([" + iso <- P.many1 f + close <- P.oneOf "})]" + if bel_brackets_match (open,close) + then return (Iso (lseq iso)) + else error "p_iso: open/close mismatch" + +-- | 'p_iso' of 'p_char_bel'. +-- +-- > P.parse p_char_iso "" "{abcde}" +p_char_iso :: P (Bel Char) +p_char_iso = p_iso p_char_bel + +-- | Given parser for 'Bel' /a/, generate 'Par' parser. +p_par :: P (Bel a) -> P (Bel a) +p_par f = do + tilde <- P.optionMaybe (P.char '~') + open <- P.oneOf "{([" + lhs <- P.many1 f + _ <- P.char ',' + rhs <- P.many1 f + close <- P.oneOf "})]" + let m = case (tilde,open,close) of + (Nothing,'{','}') -> Par_Max + (Just '~','{','}') -> Par_Min + (Nothing,'(',')') -> Par_Left + (Just '~','(',')') -> Par_Right + (Nothing,'[',']') -> Par_None + _ -> error "p_par: incoherent par" + return (Par m (lseq lhs) (lseq rhs)) + +-- | 'p_par' of 'p_char_bel'. +-- +-- > P.parse p_char_par "" "{ab,{c,de}}" +-- > P.parse p_char_par "" "{ab,~(c,de)}" +p_char_par :: P (Bel Char) +p_char_par = p_par p_char_bel + +-- | Parse 'Bel' 'Char'. +-- +-- > P.parse (P.many1 p_char_bel) "" "-_a*3" +p_char_bel :: P (Bel Char) +p_char_bel = P.choice [P.try p_char_par,p_char_iso,p_mul,p_nrests,p_char_node] + +-- | Run parser for 'Bel' of 'Char'. +bel_char_parse :: String -> Bel Char +bel_char_parse s = + either + (\e -> error ("bel_parse failed\n" ++ show e)) + lseq + (P.parse (P.many1 p_char_bel) "" s) diff --git a/Music/Theory/Time/Duration.hs b/Music/Theory/Time/Duration.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Time/Duration.hs @@ -0,0 +1,148 @@ +module Music.Theory.Time.Duration where + +import qualified Data.List.Split as S {- split -} +import Text.Printf {- base -} + +-- | Duration stored as /hours/, /minutes/, /seconds/ and /milliseconds/. +data Duration = Duration {hours :: Int + ,minutes :: Int + ,seconds :: Int + ,milliseconds :: Int} + deriving (Eq) + +-- | Convert fractional /seconds/ to integral /(seconds,milliseconds)/. +-- +-- > s_sms 1.75 == (1,750) +s_sms :: (RealFrac n,Integral i) => n -> (i,i) +s_sms s = + let s' = floor s + ms = round ((s - fromIntegral s') * 1000) + in (s',ms) + +-- | Inverse of 's_sms'. +-- +-- > sms_s (1,750) == 1.75 +sms_s :: (Integral i) => (i,i) -> Double +sms_s (s,ms) = fromIntegral s + fromIntegral ms / 1000 + +-- | 'Read' function for 'Duration' tuple. +read_duration_tuple :: String -> (Int,Int,Int,Int) +read_duration_tuple x = + let f :: (Int,Int,Double) -> (Int,Int,Int,Int) + f (h,m,s) = let (s',ms) = s_sms s in (h,m,s',ms) + in case S.splitOneOf ":" x of + [h,m,s] -> f (read h,read m,read s) + [m,s] -> f (0,read m,read s) + [s] -> f (0,0,read s) + _ -> error "read_duration_tuple" + +-- | 'Read' function for 'Duration'. Allows either @H:M:S.MS@ or +-- @M:S.MS@ or @S.MS@. +-- +-- > read_duration "01:35:05.250" == Duration 1 35 5 250 +-- > read_duration "35:05.250" == Duration 0 35 5 250 +-- > read_duration "05.250" == Duration 0 0 5 250 +read_duration :: String -> Duration +read_duration = tuple_to_duration id . read_duration_tuple + +instance Read Duration where + readsPrec _ x = [(read_duration x,"")] + +-- | 'Show' function for 'Duration'. +-- +-- > show_duration (Duration 1 35 5 250) == "01:35:05.250" +-- > show (Duration 1 15 0 000) == "01:15:00.000" +show_duration :: Duration -> String +show_duration (Duration h m s ms) = + let f :: Int -> String + f = printf "%02d" + g = f . fromIntegral + s' = sms_s (s,ms) + in concat [g h,":",g m,":",printf "%06.3f" s'] + +instance Show Duration where + show = show_duration + +normalise_minutes :: Duration -> Duration +normalise_minutes (Duration h m s ms) = + let (h',m') = m `divMod` 60 + in Duration (h + h') m' s ms + +normalise_seconds :: Duration -> Duration +normalise_seconds (Duration h m s ms) = + let (m',s') = s `divMod` 60 + in Duration h (m + m') s' ms + +normalise_milliseconds :: Duration -> Duration +normalise_milliseconds (Duration h m s ms) = + let (s',ms') = ms `divMod` 1000 + in Duration h m (s + s') ms' + +normalise_duration :: Duration -> Duration +normalise_duration = + normalise_minutes . + normalise_seconds . + normalise_milliseconds + +-- | Extract 'Duration' tuple applying filter function at each element +-- +-- > duration_tuple id (Duration 1 35 5 250) == (1,35,5,250) +duration_to_tuple :: (Int -> a) -> Duration -> (a,a,a,a) +duration_to_tuple f (Duration h m s ms) = (f h,f m,f s,f ms) + +-- | Inverse of 'duration_to_tuple'. +tuple_to_duration :: (a -> Int) -> (a,a,a,a) -> Duration +tuple_to_duration f (h,m,s,ms) = Duration (f h) (f m) (f s) (f ms) + +-- > duration_to_hours (read "01:35:05.250") == 1.5847916666666668 +duration_to_hours :: Fractional n => Duration -> n +duration_to_hours d = + let (h,m,s,ms) = duration_to_tuple fromIntegral d + in h + (m / 60) + (s / (60 * 60)) + (ms / (60 * 60 * 1000)) + +-- > duration_to_minutes (read "01:35:05.250") == 95.0875 +duration_to_minutes :: Fractional n => Duration -> n +duration_to_minutes = (* 60) . duration_to_hours + +-- > duration_to_seconds (read "01:35:05.250") == 5705.25 +duration_to_seconds :: Fractional n => Duration -> n +duration_to_seconds = (* 60) . duration_to_minutes + +-- > hours_to_duration 1.5847916 == Duration 1 35 5 250 +hours_to_duration :: RealFrac a => a -> Duration +hours_to_duration n = + let r = fromIntegral :: RealFrac a => Int -> a + h = (r . floor) n + m = (n - h) * 60 + (s,ms) = s_sms ((m - (r . floor) m) * 60) + in Duration (floor h) (floor m) s ms + +minutes_to_duration :: RealFrac a => a -> Duration +minutes_to_duration n = hours_to_duration (n / 60) + +seconds_to_duration :: RealFrac a => a -> Duration +seconds_to_duration n = minutes_to_duration (n / 60) + +nil_duration :: Duration +nil_duration = Duration 0 0 0 0 + +negate_duration :: Duration -> Duration +negate_duration (Duration h m s ms) = + let h' = if h > 0 then -h else h + m' = if h == 0 && m > 0 then -m else m + s' = if h == 0 && m == 0 && s > 0 then -s else s + ms' = if h == 0 && m == 0 && s == 0 then -ms else ms + in Duration h' m' s' ms' + +-- > duration_diff (Duration 1 35 5 250) (Duration 0 25 1 125) == Duration 1 10 4 125 +-- > duration_diff (Duration 0 25 1 125) (Duration 1 35 5 250) == Duration (-1) 10 4 125 +-- > duration_diff (Duration 0 25 1 125) (Duration 0 25 1 250) == Duration 0 0 0 (-125) +duration_diff :: Duration -> Duration -> Duration +duration_diff p q = + let f = duration_to_hours :: Duration -> Double + (p',q') = (f p,f q) + g = normalise_duration . hours_to_duration + in case compare p' q' of + LT -> negate_duration (g (q' - p')) + EQ -> nil_duration + GT -> g (p' - q') diff --git a/Music/Theory/Time/Notation.hs b/Music/Theory/Time/Notation.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Time/Notation.hs @@ -0,0 +1,43 @@ +module Music.Theory.Time.Notation where + +import Text.Printf {- base -} + +-- | Fractional seconds. +type FSEC = Double + +-- | Minutes, seconds as @(min,sec)@ +type MINSEC = (Int,Int) + +-- | Minutes, seconds, centi-seconds as @(min,sec,csec)@ +type MINCSEC = (Int,Int,Int) + +-- | Fractional seconds to @(min,sec)@. +-- +-- > map fsec_to_minsec [59.49,60,60.51] == [(0,59),(1,0),(1,1)] +fsec_to_minsec :: FSEC -> MINSEC +fsec_to_minsec tm = round tm `divMod` 60 + +-- | 'MINSEC' pretty printer. +-- +-- > map (minsec_pp . fsec_to_minsec) [59,61] == ["00:59","01:01"] +minsec_pp :: MINSEC -> String +minsec_pp (m,s) = printf "%02d:%02d" m s + +-- | Fractional seconds to @(min,sec,csec)@. +-- +-- > map fsec_to_mincsec [1,1.5,4/3] == [(0,1,0),(0,1,50),(0,1,33)] +fsec_to_mincsec :: FSEC -> MINCSEC +fsec_to_mincsec tm = + let tm' = floor tm + (m,s) = tm' `divMod` 60 + cs = round ((tm - fromIntegral tm') * 100) + in (m,s,cs) + +-- | 'MINCSEC' pretty printer. +-- +-- > map (mincsec_pp . fsec_to_mincsec) [1,4/3] == ["00:01.00","00:01.33"] +mincsec_pp :: MINCSEC -> String +mincsec_pp (m,s,cs) = printf "%02d:%02d.%02d" m s cs + +span_pp :: (t -> String) -> (t,t) -> String +span_pp f (t1,t2) = concat [f t1," - ",f t2] diff --git a/Music/Theory/Time/Seq.hs b/Music/Theory/Time/Seq.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Time/Seq.hs @@ -0,0 +1,760 @@ +-- | Basic temporal sequence functions. +module Music.Theory.Time.Seq where + +import Data.Function {- base -} +import Data.List {- base -} +import qualified Data.List.Ordered as O {- data-ordlist -} +import qualified Data.Map as M {- containers -} +import Data.Maybe {- base -} +import Data.Monoid {- base -} +import Data.Ratio {- base -} +import Safe {- safe -} + +import Music.Theory.Function {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Math as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} + +-- * Types + +-- | Sequence of elements with uniform duration. +type Useq t a = (t,[a]) + +-- | Duration sequence. The duration is the /forward/ duration of the +-- value, if it has other durations they must be encoded at /a/. +type Dseq t a = [(t,a)] + +-- | Inter-offset sequence. The duration is the interval /before/ the +-- value. To indicate the duration of the final value /a/ must have +-- an /nil/ (end of sequence) value. +type Iseq t a = [(t,a)] + +-- | Pattern sequence. The duration is a triple of /logical/, +-- /sounding/ and /forward/ durations. +type Pseq t a = [((t,t,t),a)] + +-- | Time-point sequence. To express holes /a/ must have a /empty/ +-- value. To indicate the duration of the final value /a/ must have +-- an /nil/ (end of sequence) value. +type Tseq t a = [(t,a)] + +-- | Window sequence. The temporal field is (/time/,/duration/). +-- Holes exist where @t(n) + d(n)@ '<' @t(n+1)@. Overlaps exist where +-- the same relation is '>'. +type Wseq t a = [((t,t),a)] + +-- * Zip + +pseq_zip :: [t] -> [t] -> [t] -> [a] -> Pseq t a +pseq_zip l o f a = (zip (zip3 l o f) a) + +wseq_zip :: [t] -> [t] -> [a] -> Wseq t a +wseq_zip t d a = (zip (zip t d) a) + +-- * Time span + +-- | Given functions for deriving start and end times calculate time +-- span of sequence. +-- +-- > seq_tspan id id [] == (0,0) +-- > seq_tspan id id (zip [0..9] ['a'..]) == (0,9) +seq_tspan :: Num n => (t -> n) -> (t -> n) -> [(t,a)] -> (n,n) +seq_tspan st et sq = + (maybe 0 (st . fst) (headMay sq) + ,maybe 0 (et . fst) (lastMay sq)) + +tseq_tspan :: Num t => Tseq t a -> (t,t) +tseq_tspan = seq_tspan id id + +wseq_tspan :: Num t => Wseq t a -> (t,t) +wseq_tspan = seq_tspan fst (uncurry (+)) + +-- * Duration + +dseq_dur :: Num t => Dseq t a -> t +dseq_dur = sum . map fst + +iseq_dur :: Num t => Iseq t a -> t +iseq_dur = sum . map fst + +pseq_dur :: Num t => Pseq t a -> t +pseq_dur = sum . map (T.t3_third . fst) + +-- | The interval of 'tseq_tspan'. +-- +-- > tseq_dur (zip [0..] "abcde|") == 5 +tseq_dur :: Num t => Tseq t a -> t +tseq_dur = uncurry subtract . tseq_tspan + +-- | The interval of 'wseq_tspan'. +-- +-- > wseq_dur (zip (zip [0..] (repeat 2)) "abcde") == 6 +wseq_dur :: Num t => Wseq t a -> t +wseq_dur = uncurry subtract . wseq_tspan + +-- * Window + +-- | Keep only elements in the indicated temporal window. +-- +-- > let r = [((5,1),'e'),((6,1),'f'),((7,1),'g'),((8,1),'h')] +-- > in wseq_twindow (5,9) (zip (zip [1..10] (repeat 1)) ['a'..]) == r +wseq_twindow :: (Num t, Ord t) => (t,t) -> Wseq t a -> Wseq t a +wseq_twindow (w0,w1) = + let f (st,du) = w0 <= st && (st + du) <= w1 + in wseq_tfilter f + +-- * Append + +dseq_append :: Dseq t a -> Dseq t a -> Dseq t a +dseq_append = (++) + +iseq_append :: Iseq t a -> Iseq t a -> Iseq t a +iseq_append = (++) + +pseq_append :: Pseq t a -> Pseq t a -> Pseq t a +pseq_append = (++) + +-- * Merge + +-- | Merge comparing only on time. +tseq_merge :: Ord t => Tseq t a -> Tseq t a -> Tseq t a +tseq_merge = O.mergeBy (compare `on` fst) + +-- | Merge, where times are equal compare values. +tseq_merge_by :: Ord t => T.Compare_F a -> Tseq t a -> Tseq t a -> Tseq t a +tseq_merge_by cmp = T.merge_by_two_stage fst cmp snd + +{- | Merge, where times are equal apply /f/ to form a single value. + +> let {p = zip [1,3,5] "abc" +> ;q = zip [1,2,3] "ABC" +> ;left_r = [(1,'a'),(2,'B'),(3,'b'),(5,'c')] +> ;right_r = [(1,'A'),(2,'B'),(3,'C'),(5,'c')]} +> in tseq_merge_resolve (\x _ -> x) p q == left_r && +> tseq_merge_resolve (\_ x -> x) p q == right_r + +-} +tseq_merge_resolve :: Ord t => (a -> a -> a) -> Tseq t a -> Tseq t a -> Tseq t a +tseq_merge_resolve f = + let cmp = compare `on` fst + g (t,p) (_,q) = (t,f p q) + in T.merge_by_resolve g cmp + +wseq_merge :: Ord t => Wseq t a -> Wseq t a -> Wseq t a +wseq_merge = O.mergeBy (compare `on` (fst . fst)) + +-- * Lookup + +tseq_lookup_window_by :: (t -> t -> Ordering) -> Tseq t e -> t -> (Maybe (t,e),Maybe (t,e)) +tseq_lookup_window_by cmp = + let recur l sq t = + case sq of + [] -> (l,Nothing) + (t',e):sq' -> case cmp t t' of + LT -> (l,Just (t',e)) + _ -> case sq' of + [] -> (Just (t',e),Nothing) + (t'',e'):_ -> case cmp t t'' of + LT -> (Just (t',e),Just (t'',e')) + _ -> recur (Just (t',e)) sq' t + in recur Nothing + +tseq_lookup_active_by :: (t -> t -> Ordering) -> Tseq t e -> t -> Maybe e +tseq_lookup_active_by cmp sq = fmap snd . fst . tseq_lookup_window_by cmp sq + +tseq_lookup_active :: Ord t => Tseq t e -> t -> Maybe e +tseq_lookup_active = tseq_lookup_active_by compare + +tseq_lookup_active_by_def :: e -> (t -> t -> Ordering) -> Tseq t e -> t -> e +tseq_lookup_active_by_def def cmp sq = fromMaybe def . tseq_lookup_active_by cmp sq + +tseq_lookup_active_def :: Ord t => e -> Tseq t e -> t -> e +tseq_lookup_active_def def = tseq_lookup_active_by_def def compare + +-- * Lseq + +data Interpolation_T = None | Linear + deriving (Eq,Enum,Show) + +-- | Variant of 'Tseq' where nodes have an 'Intepolation_T' value. +type Lseq t a = Tseq (t,Interpolation_T) a + +-- | Linear interpolation. +lerp :: (Fractional t,Real t,Fractional e) => (t,e) -> (t,e) -> t -> e +lerp (t0,e0) (t1,e1) t = + let n = t1 - t0 + m = t - t0 + l = m / n + in realToFrac l * (e1 - e0) + e0 + +-- | Temporal map. +lseq_tmap :: (t -> t') -> Lseq t a -> Lseq t' a +lseq_tmap f = let g ((t,i),e) = ((f t,i),e) in map g + +-- | This can give 'Nothing' if /t/ precedes the 'Lseq' or if /t/ is +-- after the final element of 'Lseq' and that element has an +-- interpolation type other than 'None'. +lseq_lookup :: (Fractional t,Real t,Fractional e) => (t -> t -> Ordering) -> Lseq t e -> t -> Maybe e +lseq_lookup cmp sq t = + case tseq_lookup_window_by (cmp `on` fst) sq (t,undefined) of + (Nothing,_) -> Nothing + (Just ((_,None),e),_) -> Just e + (Just ((t0,Linear),e0),Just ((t1,_),e1)) -> Just (lerp (t0,e0) (t1,e1) t) + _ -> Nothing + +-- | 'error'ing variant. +lseq_lookup_err :: (Fractional t,Real t,Fractional e) => (t -> t -> Ordering) -> Lseq t e -> t -> e +lseq_lookup_err cmp sq = fromMaybe (error "lseq_lookup") . lseq_lookup cmp sq + +-- * Map, Filter, Find + +seq_tmap :: (t -> t') -> [(t,a)] -> [(t',a)] +seq_tmap f = map (\(p,q) -> (f p,q)) + +seq_map :: (b -> c) -> [(a,b)] -> [(a,c)] +seq_map f = map (\(p,q) -> (p,f q)) + +-- | Map /t/ and /e/ simultaneously. +seq_bimap :: (t -> t') -> (e -> e') -> [(t,e)] -> [(t',e')] +seq_bimap f g = map (\(p,q) -> (f p,g q)) + +seq_tfilter :: (t -> Bool) -> [(t,a)] -> [(t,a)] +seq_tfilter f = filter (f . fst) + +seq_filter :: (b -> Bool) -> [(a,b)] -> [(a,b)] +seq_filter f = filter (f . snd) + +seq_find :: (a -> Bool) -> [(t,a)] -> Maybe (t,a) +seq_find f = let f' (_,a) = f a in find f' + +-- * Maybe + +-- | 'mapMaybe' variant. +seq_map_maybe :: (p -> Maybe q) -> [(t,p)] -> [(t,q)] +seq_map_maybe f = + let g (t,e) = maybe Nothing (\e' -> Just (t,e')) (f e) + in mapMaybe g + +-- | Variant of 'catMaybes'. +seq_cat_maybes :: [(t,Maybe q)] -> [(t,q)] +seq_cat_maybes = seq_map_maybe id + +-- | If value is unchanged, according to /f/, replace with 'Nothing'. +-- +-- > let r = [(1,'s'),(2,'t'),(4,'r'),(6,'i'),(7,'n'),(9,'g')] +-- > in seq_cat_maybes (seq_changed_by (==) (zip [1..] "sttrrinng")) == r +seq_changed_by :: (a -> a -> Bool) -> [(t,a)] -> [(t,Maybe a)] +seq_changed_by f l = + let recur z sq = + case sq of + [] -> [] + (t,e):sq' -> if f e z + then (t,Nothing) : recur z sq' + else (t,Just e) : recur e sq' + in case l of + [] -> [] + (t,e) : l' -> (t,Just e) : recur e l' + +-- | 'seq_changed_by' '=='. +seq_changed :: Eq a => [(t,a)] -> [(t,Maybe a)] +seq_changed = seq_changed_by (==) + +-- * Specialised temporal maps. + +-- | Apply /f/ at time points of 'Wseq'. +wseq_tmap_st :: (t -> t) -> Wseq t a -> Wseq t a +wseq_tmap_st f = let g (t,d) = (f t,d) in seq_tmap g + +-- | Apply /f/ at durations of elements of 'Wseq'. +wseq_tmap_dur :: (t -> t) -> Wseq t a -> Wseq t a +wseq_tmap_dur f = let g (t,d) = (t,f d) in seq_tmap g + +-- * Partition + +-- | Given a function that determines a /voice/ for a value, partition +-- a sequence into voices. +seq_partition :: Ord v => (a -> v) -> [(t,a)] -> [(v,[(t,a)])] +seq_partition voice sq = + let assign m (t,a) = M.insertWith (++) (voice a) [(t,a)] m + from_map = sortBy (compare `on` fst) . + map (\(v,l) -> (v,reverse l)) . + M.toList + in from_map (foldl assign M.empty sq) + +-- | Type specialised 'seq_partition'. +-- +-- > let {p = zip [0,1,3,5] (zip (repeat 0) "abcd") +-- > ;q = zip [2,4,6,7] (zip (repeat 1) "ABCD") +-- > ;sq = tseq_merge p q} +-- > in tseq_partition fst sq == [(0,p),(1,q)] +tseq_partition :: Ord v => (a -> v) -> Tseq t a -> [(v,Tseq t a)] +tseq_partition = seq_partition + +wseq_partition :: Ord v => (a -> v) -> Wseq t a -> [(v,Wseq t a)] +wseq_partition = seq_partition + +-- * Coalesce + +-- | Given a decision predicate and a join function, recursively join +-- adjacent elements. +-- +-- > coalesce_f undefined undefined [] == [] +-- > coalesce_f (==) const "abbcccbba" == "abcba" +-- > coalesce_f (==) (+) [1,2,2,3,3,3] == [1,4,6,3] +coalesce_f :: (t -> t -> Bool) -> (t -> t -> t) -> [t] -> [t] +coalesce_f dec_f jn_f z = + let recur p l = + case l of + [] -> [p] + c:l' -> if dec_f p c + then recur (jn_f p c) l' + else p : recur c l' + in case z of + [] -> [] + e0:z' -> recur e0 z' + +-- | 'coalesce_f' using 'mappend' for the join function. +coalesce_m :: Monoid t => (t -> t -> Bool) -> [t] -> [t] +coalesce_m dec_f = coalesce_f dec_f mappend + +-- | Form of 'coalesce_f' where the decision predicate is on the +-- /element/, and a join function sums the /times/. +-- +-- > let r = [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')] +-- > in seq_coalesce (==) const (useq_to_dseq (1,"abbcccdde")) == r +seq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> [(t,a)] -> [(t,a)] +seq_coalesce dec_f jn_f = + let dec_f' = dec_f `on` snd + jn_f' (t1,a1) (t2,a2) = (t1 + t2,jn_f a1 a2) + in coalesce_f dec_f' jn_f' + +dseq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> Dseq t a -> Dseq t a +dseq_coalesce = seq_coalesce + +-- | Given /equality/ predicate, simplify sequence by summing +-- durations of adjacent /equal/ elements. This is a special case of +-- 'dseq_coalesce' where the /join/ function is 'const'. The +-- implementation is simpler and non-recursive. +-- +-- > let {d = useq_to_dseq (1,"abbcccdde") +-- > ;r = dseq_coalesce (==) const d} +-- > in dseq_coalesce' (==) d == r +dseq_coalesce' :: Num t => (a -> a -> Bool) -> Dseq t a -> Dseq t a +dseq_coalesce' eq = + let f l = let (t,e:_) = unzip l in (sum t,e) + in map f . groupBy (eq `on` snd) + +iseq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> Iseq t a -> Iseq t a +iseq_coalesce = seq_coalesce + +-- * T-coalesce + +seq_tcoalesce :: (t -> t -> Bool) -> (a -> a -> a) -> [(t,a)] -> [(t,a)] +seq_tcoalesce eq_f jn_f = + let dec_f = eq_f `on` fst + jn_f' (t,a1) (_,a2) = (t,jn_f a1 a2) + in coalesce_f dec_f jn_f' + +tseq_tcoalesce :: Eq t => (a -> a -> a) -> Tseq t a -> Tseq t a +tseq_tcoalesce = seq_tcoalesce (==) + +wseq_tcoalesce :: ((t,t) -> (t,t) -> Bool) -> (a -> a -> a) -> Wseq t a -> Wseq t a +wseq_tcoalesce = seq_tcoalesce + +-- * Group + +-- | Post-process 'groupBy' of /cmp/ 'on' 'fst'. +-- +-- > let r = [(0,"a"),(1,"bc"),(2,"de"),(3,"f")] +-- > in group_f (==) (zip [0,1,1,2,2,3] ['a'..]) == r +group_f :: (Eq t,Num t) => (t -> t -> Bool) -> [(t,a)] -> [(t,[a])] +group_f cmp = + let f l = let (t,a) = unzip l + in case t of + [] -> error "group_f: []?" + t0:_ -> (t0,a) + in map f . groupBy (cmp `on` fst) + +-- | Group values at equal time points. +-- +-- > let r = [(0,"a"),(1,"bc"),(2,"de"),(3,"f")] +-- > in tseq_group (zip [0,1,1,2,2,3] ['a'..]) == r +tseq_group :: (Eq t,Num t) => Tseq t a -> Tseq t [a] +tseq_group = group_f (==) + +-- | Group values where the inter-offset time is @0@ to the left. +-- +-- > let r = [(0,"a"),(1,"bcd"),(1,"ef")] +-- > in iseq_group (zip [0,1,0,0,1,0] ['a'..]) == r +iseq_group :: (Eq t,Num t) => Iseq t a -> Iseq t [a] +iseq_group = group_f (\_ d -> d == 0) + +-- * Fill + +-- | Set durations so that there are no gaps or overlaps. +-- +-- > let r = wseq_zip [0,3,5] [3,2,1] "abc" +-- > in wseq_fill_dur (wseq_zip [0,3,5] [2,1,1] "abc") == r +wseq_fill_dur :: Num t => Wseq t a -> Wseq t a +wseq_fill_dur l = + let f (((t1,_),e),((t2,_),_)) = ((t1,t2-t1),e) + in map f (T.adj2 1 l) ++ [last l] + +-- * Dseq + +dseq_lcm :: Dseq Rational e -> Integer +dseq_lcm = foldl1 lcm . map (denominator . fst) + +-- | Scale by lcm so that all durations are integral. +dseq_set_whole :: [Dseq Rational e] -> [Dseq Integer e] +dseq_set_whole sq = + let m = maximum (map dseq_lcm sq) + t_f n = T.rational_whole_err (n * fromIntegral m) + in map (dseq_tmap t_f) sq + +-- * Tseq + +-- | Given a a default value, a 'Tseq' /sq/ and a list of time-points +-- /t/, generate a Tseq that is a union of the timepoints at /sq/ and +-- /t/ where times in /t/ not at /sq/ are given the /current/ value, +-- or /def/ if there is no value. +-- +-- > tseq_latch 'a' [(2,'b'),(4,'c')] [1..5] == zip [1..5] "abbcc" +tseq_latch :: Ord t => a -> Tseq t a -> [t] -> Tseq t a +tseq_latch def sq t = + case (sq,t) of + ([],_) -> zip t (repeat def) + (_,[]) -> [] + ((sq_t,sq_e):sq',t0:t') -> case compare sq_t t0 of + LT -> (sq_t,sq_e) : tseq_latch sq_e sq' t + EQ -> (sq_t,sq_e) : tseq_latch sq_e sq' t' + GT -> (t0,def) : tseq_latch def sq t' + +-- * Wseq + +-- | Transform 'Wseq' to 'Tseq' by discaring durations. +wseq_discard_dur :: Wseq t a -> Tseq t a +wseq_discard_dur = let f ((t,_),e) = (t,e) in map f + +-- | Edit durations to ensure that notes don't overlap. If the same +-- note is played simultaneously delete shorter note. If a note +-- extends into a later note shorten duration (apply /d_fn/ to iot). +wseq_remove_overlaps :: (Eq e,Ord t,Num t) => + (e -> e -> Bool) -> (t -> t) -> + Wseq t e -> Wseq t e +wseq_remove_overlaps eq_fn d_fn = + let go sq = + case sq of + [] -> [] + ((t,d),a):sq' -> + case find (eq_fn a . snd) sq' of + Nothing -> ((t,d),a) : go sq' + Just ((t',d'),a') -> + if t == t' + then if d <= d' + then -- delete LHS + go sq' + else -- delete RHS + ((t,d),a) : + go (delete ((t',d'),a') sq') + else if t' < t + d + then ((t,d_fn (t' - t)),a) : go sq' + else ((t,d),a) : go sq' + in go + +-- | Unjoin elements (assign equal time stamps to all elements). +seq_unjoin :: [(t,[e])] -> [(t,e)] +seq_unjoin = let f (t,e) = zip (repeat t) e in concatMap f + +-- | Type specialised. +wseq_unjoin :: Wseq t [e] -> Wseq t e +wseq_unjoin = seq_unjoin + +-- * On/Off + +-- | Container for values that have /on/ and /off/ modes. +data On_Off a = On a | Off a deriving (Eq,Show) + +-- | Structural comparison at 'On_Off', 'On' compares less than 'Off'. +cmp_on_off :: On_Off a -> On_Off b -> Ordering +cmp_on_off p q = + case (p,q) of + (On _,Off _) -> LT + (On _,On _) -> EQ + (Off _,Off _) -> EQ + (Off _,On _) -> GT + +-- | Translate container types. +either_to_on_off :: Either a a -> On_Off a +either_to_on_off p = + case p of + Left a -> On a + Right a -> Off a + +-- | Translate container types. +on_off_to_either :: On_Off a -> Either a a +on_off_to_either p = + case p of + On a -> Left a + Off a -> Right a + +-- | Convert 'Wseq' to 'Tseq' transforming elements to 'On' and 'Off' +-- parts. When merging, /off/ elements precede /on/ elements at equal +-- times. +-- +-- > let {sq = [((0,5),'a'),((2,2),'b')] +-- > ;r = [(0,On 'a'),(2,On 'b'),(4,Off 'b'),(5,Off 'a')]} +-- > in wseq_on_off sq == r +-- +-- > let {sq = [((0,1),'a'),((1,1),'b'),((2,1),'c')] +-- > ;r = [(0,On 'a'),(1,Off 'a') +-- > ,(1,On 'b'),(2,Off 'b') +-- > ,(2,On 'c'),(3,Off 'c')]} +-- > in wseq_on_off sq == r +wseq_on_off :: (Num t, Ord t) => Wseq t a -> Tseq t (On_Off a) +wseq_on_off sq = + let f ((t,d),a) = [(t,On a),(t + d,Off a)] + g l = + case l of + [] -> [] + e:l' -> tseq_merge_by (T.ordering_invert .: cmp_on_off) e (g l') + in g (map f sq) + +-- | 'on_off_to_either' of 'wseq_on_off'. +wseq_on_off_either :: (Num t, Ord t) => Wseq t a -> Tseq t (Either a a) +wseq_on_off_either = tseq_map on_off_to_either . wseq_on_off + +-- | Variant that applies /on/ and /off/ functions to nodes. +-- +-- > let {sq = [((0,5),'a'),((2,2),'b')] +-- > ;r = [(0,'A'),(2,'B'),(4,'b'),(5,'a')]} +-- > in wseq_on_off_f Data.Char.toUpper id sq == r +wseq_on_off_f :: (Ord t,Num t) => (a -> b) -> (a -> b) -> Wseq t a -> Tseq t b +wseq_on_off_f f g = tseq_map (either f g) . wseq_on_off_either + +-- | Inverse of 'wseq_on_off' given a predicate function for locating +-- the /off/ node of an /on/ node. +-- +-- > let {sq = [(0,On 'a'),(2,On 'b'),(4,Off 'b'),(5,Off 'a')] +-- > ;r = [((0,5),'a'),((2,2),'b')]} +-- > in tseq_on_off_to_wseq (==) sq == r +tseq_on_off_to_wseq :: Num t => (a -> a -> Bool) -> Tseq t (On_Off a) -> Wseq t a +tseq_on_off_to_wseq cmp = + let cmp' x e = + case e of + Off x' -> cmp x x' + _ -> False + f e r = case seq_find (cmp' e) r of + Nothing -> error "tseq_on_off_to_wseq: no matching off?" + Just (t,_) -> t + go sq = case sq of + [] -> [] + (_,Off _) : sq' -> go sq' + (t,On e) : sq' -> let t' = f e sq' in ((t,t' - t),e) : go sq' + in go + +-- * Interop + +useq_to_dseq :: Useq t a -> Dseq t a +useq_to_dseq (t,e) = zip (repeat t) e + +-- | The conversion requires a start time and a /nil/ value used as an +-- /eof/ marker. Productive given indefinite input sequence. +-- +-- > let r = zip [0,1,3,6,8,9] "abcde|" +-- > in dseq_to_tseq 0 '|' (zip [1,2,3,2,1] "abcde") == r +-- +-- > let {d = zip [1,2,3,2,1] "abcde" +-- > ;r = zip [0,1,3,6,8,9,10] "abcdeab"} +-- > in take 7 (dseq_to_tseq 0 undefined (cycle d)) == r +dseq_to_tseq :: Num t => t -> a -> Dseq t a -> Tseq t a +dseq_to_tseq t0 nil sq = + let (d,a) = unzip sq + t = T.dx_d t0 d + a' = a ++ [nil] + in zip t a' + +-- | Variant where the /nil/ is take as the last element of the +-- sequence. +-- +-- > let r = zip [0,1,3,6,8,9] "abcdee" +-- > in dseq_to_tseq_last 0 (zip [1,2,3,2,1] "abcde") == r +dseq_to_tseq_last :: Num t => t -> Dseq t a -> Tseq t a +dseq_to_tseq_last t0 sq = dseq_to_tseq t0 (snd (last sq)) sq + +-- | The conversion requires a start time and does not consult the +-- /logical/ duration. +-- +-- > let p = pseq_zip (repeat undefined) (cycle [1,2]) (cycle [1,1,2]) "abcdef" +-- > in pseq_to_wseq 0 p == wseq_zip [0,1,2,4,5,6] (cycle [1,2]) "abcdef" +pseq_to_wseq :: Num t => t -> Pseq t a -> Wseq t a +pseq_to_wseq t0 sq = + let (p,a) = unzip sq + (_,d,f) = unzip3 p + t = T.dx_d t0 f + in wseq_zip t d a + +-- | The last element of 'Tseq' is required to be an /eof/ marker that +-- has no duration and is not represented in the 'Dseq'. +-- +-- > let r = zip [1,2,3,2,1] "abcde" +-- > in tseq_to_dseq undefined (zip [0,1,3,6,8,9] "abcde|") == r +-- +-- > let r = zip [1,2,3,2,1] "-abcd" +-- > in tseq_to_dseq '-' (zip [1,3,6,8,9] "abcd|") == r +tseq_to_dseq :: (Ord t,Num t) => a -> Tseq t a -> Dseq t a +tseq_to_dseq empty sq = + let (t,a) = unzip sq + d = T.d_dx t + in case t of + [] -> [] + t0:_ -> if t0 > 0 then (t0,empty) : zip d a else zip d a + +-- | The last element of 'Tseq' is required to be an /eof/ marker that +-- has no duration and is not represented in the 'Wseq'. The duration +-- of each value is either derived from the value, if an /dur/ +-- function is given, or else the inter-offset time. +-- +-- > let r = wseq_zip [0,1,3,6,8] [1,2,3,2,1] "abcde" +-- > in tseq_to_wseq Nothing (zip [0,1,3,6,8,9] "abcde|") == r +-- +-- > let r = wseq_zip [0,1,3,6,8] (map fromEnum "abcde") "abcde" +-- > in tseq_to_wseq (Just fromEnum) (zip [0,1,3,6,8,9] "abcde|") == r +tseq_to_wseq :: Num t => Maybe (a -> t) -> Tseq t a -> Wseq t a +tseq_to_wseq dur_f sq = + let (t,a) = unzip sq + d = case dur_f of + Just f -> map f (fst (T.separate_last a)) + Nothing -> T.d_dx t + in wseq_zip t d a + +tseq_to_iseq :: Num t => Tseq t a -> Dseq t a +tseq_to_iseq = + let recur n p = + case p of + [] -> [] + (t,e):p' -> (t - n,e) : recur t p' + in recur 0 + +-- | Requires start time. +-- +-- > let r = zip (zip [0,1,3,6,8,9] [1,2,3,2,1]) "abcde" +-- > in dseq_to_wseq 0 (zip [1,2,3,2,1] "abcde") == r +dseq_to_wseq :: Num t => t -> Dseq t a -> Wseq t a +dseq_to_wseq t0 sq = + let (d,a) = unzip sq + t = T.dx_d t0 d + in zip (zip t d) a + +-- | Inverse of 'dseq_to_wseq'. The /empty/ value is used to fill +-- holes in 'Wseq'. If values overlap at 'Wseq' durations are +-- truncated. +-- +-- > let w = wseq_zip [0,1,3,6,8,9] [1,2,3,2,1] "abcde" +-- > in wseq_to_dseq '-' w == zip [1,2,3,2,1] "abcde" +-- +-- > let w = wseq_zip [3,10] [6,2] "ab" +-- > in wseq_to_dseq '-' w == zip [3,6,1,2] "-a-b" +-- +-- > let w = wseq_zip [0,1] [2,2] "ab" +-- > in wseq_to_dseq '-' w == zip [1,2] "ab" +-- +-- > let w = wseq_zip [0,0,0] [2,2,2] "abc" +-- > in wseq_to_dseq '-' w == zip [0,0,2] "abc" +wseq_to_dseq :: (Num t,Ord t) => a -> Wseq t a -> Dseq t a +wseq_to_dseq empty sq = + let f (((st0,d),e),((st1,_),_)) = + let d' = st1 - st0 + in case compare d d' of + LT -> [(d,e),(d'-d,empty)] + EQ -> [(d,e)] + GT -> [(d',e)] + ((_,dN),eN) = last sq + r = concatMap f (T.adj2 1 sq) ++ [(dN,eN)] + in case sq of + ((st,_),_):_ -> if st > 0 then (st,empty) : r else r + [] -> error "wseq_to_dseq" + +-- * Measures + +-- | Given a list of 'Dseq' (measures) convert to a list of 'Tseq' and +-- the end time of the overall sequence. +-- +-- > let r = [[(0,'a'),(1,'b'),(3,'c')],[(4,'d'),(7,'e'),(9,'f')]] +-- > in dseql_to_tseql 0 [zip [1,2,1] "abc",zip [3,2,1] "def"] == (10,r) +dseql_to_tseql :: Num t => t -> [Dseq t a] -> (t,[Tseq t a]) +dseql_to_tseql = + let f z dv = + let (tm,el) = unzip dv + (z',r) = T.dx_d' z tm + in (z',zip r el) + in mapAccumL f + +-- * Type specialised map + +dseq_tmap :: (t -> t') -> Dseq t a -> Dseq t' a +dseq_tmap = seq_tmap + +pseq_tmap :: ((t,t,t) -> (t',t',t')) -> Pseq t a -> Pseq t' a +pseq_tmap = seq_tmap + +tseq_tmap :: (t -> t') -> Dseq t a -> Dseq t' a +tseq_tmap = seq_tmap + +tseq_bimap :: (t -> t') -> (e -> e') -> Tseq t e -> Tseq t' e' +tseq_bimap = seq_bimap + +wseq_tmap :: ((t,t) -> (t',t')) -> Wseq t a -> Wseq t' a +wseq_tmap = seq_tmap + +dseq_map :: (a -> b) -> Dseq t a -> Dseq t b +dseq_map = seq_map + +pseq_map :: (a -> b) -> Pseq t a -> Pseq t b +pseq_map = seq_map + +tseq_map :: (a -> b) -> Tseq t a -> Tseq t b +tseq_map = seq_map + +wseq_map :: (a -> b) -> Wseq t a -> Wseq t b +wseq_map = seq_map + +-- * Type specialised filter + +dseq_tfilter :: (t -> Bool) -> Dseq t a -> Dseq t a +dseq_tfilter = seq_tfilter + +iseq_tfilter :: (t -> Bool) -> Iseq t a -> Iseq t a +iseq_tfilter = seq_tfilter + +pseq_tfilter :: ((t,t,t) -> Bool) -> Pseq t a -> Pseq t a +pseq_tfilter = seq_tfilter + +tseq_tfilter :: (t -> Bool) -> Tseq t a -> Tseq t a +tseq_tfilter = seq_tfilter + +wseq_tfilter :: ((t,t) -> Bool) -> Wseq t a -> Wseq t a +wseq_tfilter = seq_tfilter + +dseq_filter :: (a -> Bool) -> Dseq t a -> Dseq t a +dseq_filter = seq_filter + +iseq_filter :: (a -> Bool) -> Iseq t a -> Iseq t a +iseq_filter = seq_filter + +pseq_filter :: (a -> Bool) -> Pseq t a -> Pseq t a +pseq_filter = seq_filter + +tseq_filter :: (a -> Bool) -> Tseq t a -> Tseq t a +tseq_filter = seq_filter + +wseq_filter :: (a -> Bool) -> Wseq t a -> Wseq t a +wseq_filter = seq_filter + +-- * Type specialised maybe + +wseq_map_maybe :: (a -> Maybe b) -> Wseq t a -> Wseq t b +wseq_map_maybe = seq_map_maybe + +wseq_cat_maybes :: Wseq t (Maybe a) -> Wseq t a +wseq_cat_maybes = seq_cat_maybes 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,10 +1,12 @@ -- | Time Signatures. module Music.Theory.Time_Signature where -import Data.Ratio +import Data.Ratio {- base -} + import Music.Theory.Duration import Music.Theory.Duration.Name import Music.Theory.Duration.RQ +import Music.Theory.Math -- | A Time Signature is a /(numerator,denominator)/ pair. type Time_Signature = (Integer,Integer) @@ -57,6 +59,15 @@ ts_rq :: Time_Signature -> RQ ts_rq (n,d) = (4 * n) % d +-- | 'Time_Signature' derived from whole note duration in 'RQ' form. +-- +-- > map rq_to_ts [4,3/2,7/4,6] == [(4,4),(3,8),(7,16),(6,4)] +rq_to_ts :: Rational -> Time_Signature +rq_to_ts rq = + let n = numerator rq + d = denominator rq * 4 + in (n,d) + -- | Uniform division of time signature. -- -- > ts_divisions (3,4) == [1,1,1] @@ -100,3 +111,85 @@ j = sum (map fst t') in (j,i) +-- * Composite Time Signatures + +-- | A composite time signature is a sequence of 'Time_Signature's. +type Composite_Time_Signature = [Time_Signature] + +-- | The 'RQ' is the 'sum' of 'ts_rq' of the elements. +-- +-- > cts_rq [(3,4),(1,8)] == 3 + 1/2 +cts_rq :: Composite_Time_Signature -> RQ +cts_rq = sum . map ts_rq + +-- | The divisions are the 'concat' of the 'ts_divisions' of the +-- elements. +-- +-- > cts_divisions [(3,4),(1,8)] == [1,1,1,1/2] +cts_divisions :: Composite_Time_Signature -> [RQ] +cts_divisions = concatMap ts_divisions + +-- | Pulses are 1-indexed, RQ locations are 0-indexed. +-- +-- > map (cts_pulse_to_rq [(2,4),(1,8),(1,4)]) [1 .. 4] == [0,1,2,2 + 1/2] +cts_pulse_to_rq :: Composite_Time_Signature -> Int -> RQ +cts_pulse_to_rq cts p = + let dv = cts_divisions cts + in sum (take (p - 1) dv) + +-- | Variant that gives the /window/ of the pulse (ie. the start +-- location and the duration). +-- +-- > let r = [(0,1),(1,1),(2,1/2),(2 + 1/2,1)] +-- > in map (cts_pulse_to_rqw [(2,4),(1,8),(1,4)]) [1 .. 4] == r +cts_pulse_to_rqw :: Composite_Time_Signature -> Int -> (RQ,RQ) +cts_pulse_to_rqw cts p = (cts_pulse_to_rq cts p,cts_divisions cts !! (p - 1)) + +-- * Rational Time Signatures + +-- | A rational time signature is a 'Composite_Time_Signature' where +-- the parts are 'Rational'. +type Rational_Time_Signature = [(Rational,Rational)] + +-- | The 'sum' of the RQ of the elements. +-- +-- > rts_rq [(3,4),(1,8)] == 3 + 1/2 +-- > rts_rq [(3/2,4),(1/2,8)] == 3/2 + 1/4 +rts_rq :: Rational_Time_Signature -> RQ +rts_rq = + let f (n,d) = (4 * n) / d + in sum . map f + +-- | The /divisions/ of the elements. +-- +-- > rts_divisions [(3,4),(1,8)] == [1,1,1,1/2] +-- > rts_divisions [(3/2,4),(1/2,8)] == [1,1/2,1/4] +rts_divisions :: Rational_Time_Signature -> [[RQ]] +rts_divisions = + let f (n,d) = let (ni,nf) = integral_and_fractional_parts n + rq = recip (d / 4) + ip = replicate ni rq + in if nf == 0 then ip else ip ++ [nf * rq] + in map f + +-- > rts_derive [1,1,1,1/2] +-- > rts_derive [1,1/2,1/4] +rts_derive :: [RQ] -> Rational_Time_Signature +rts_derive = let f rq = (rq,4) in map f + +-- | Pulses are 1-indexed, RQ locations are 0-indexed. +-- +-- > map (rts_pulse_to_rq [(2,4),(1,8),(1,4)]) [1 .. 4] == [0,1,2,2 + 1/2] +-- > map (rts_pulse_to_rq [(3/2,4),(1/2,8),(1/4,4)]) [1 .. 4] == [0,1,3/2,7/4] +rts_pulse_to_rq :: Rational_Time_Signature -> Int -> RQ +rts_pulse_to_rq rts p = + let dv = concat (rts_divisions rts) + in sum (take (p - 1) dv) + +-- | Variant that gives the /window/ of the pulse (ie. the start +-- location and the duration). +-- +-- > let r = [(0,1),(1,1),(2,1/2),(2 + 1/2,1)] +-- > in map (rts_pulse_to_rqw [(2,4),(1,8),(1,4)]) [1 .. 4] == r +rts_pulse_to_rqw :: Rational_Time_Signature -> Int -> (RQ,RQ) +rts_pulse_to_rqw ts p = (rts_pulse_to_rq ts p,concat (rts_divisions ts) !! (p - 1)) diff --git a/Music/Theory/Tuning.hs b/Music/Theory/Tuning.hs --- a/Music/Theory/Tuning.hs +++ b/Music/Theory/Tuning.hs @@ -1,31 +1,23 @@ -- | Tuning theory module Music.Theory.Tuning where -import Data.List -import Data.Ratio - --- * Either/Maybe - --- | Maybe 'Left' of 'Either'. -fromLeft :: Either a b -> Maybe a -fromLeft e = - case e of - Left x -> Just x - _ -> Nothing +import Data.Fixed {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} +import Safe {- safe -} --- | Maybe 'Right' of 'Either'. -fromRight :: Either a b -> Maybe b -fromRight e = - case e of - Right x -> Just x - _ -> Nothing +import qualified Music.Theory.Either as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} -- * Types -- | An approximation of a ratio. type Approximate_Ratio = Double --- | A real valued division of a tone into one hundred parts. +-- | A real valued division of a semi-tone into one hundred parts, and +-- hence of the octave into @1200@ parts. type Cents = Double -- | A tuning specified 'Either' as a sequence of exact ratios, or as @@ -42,35 +34,46 @@ -- | 'Maybe' exact ratios of 'Tuning'. ratios :: Tuning -> Maybe [Rational] -ratios = fromLeft . ratios_or_cents +ratios = T.fromLeft . ratios_or_cents +-- | 'error'ing variant. +ratios_err :: Tuning -> [Rational] +ratios_err = fromMaybe (error "ratios") . ratios + -- | Possibly inexact 'Cents' of tuning. cents :: Tuning -> [Cents] -cents = either (map to_cents_r) id . ratios_or_cents +cents = either (map ratio_to_cents) id . ratios_or_cents -- | 'map' 'round' '.' 'cents'. cents_i :: Integral i => Tuning -> [i] cents_i = map round . cents --- | Convert from cents invterval to frequency ratio. +-- | Variant of 'cents' that includes octave at right. +cents_octave :: Tuning -> [Cents] +cents_octave t = cents t ++ [ratio_to_cents (octave_ratio t)] + +-- | Convert from interval in cents to frequency ratio. -- -- > map cents_to_ratio [0,701.9550008653874,1200] == [1,3/2,2] cents_to_ratio :: Floating a => a -> a cents_to_ratio n = 2 ** (n / 1200) --- | Convert from frequency ratio to cents interval. --- --- > map ratio_to_cents [1,4/3,2] == [0.0,498.04499913461245,1200.0] -ratio_to_cents :: Floating a => a -> a -ratio_to_cents n = logBase 2 n * 1200 - -- | Possibly inexact 'Approximate_Ratio's of tuning. approximate_ratios :: Tuning -> [Approximate_Ratio] approximate_ratios = either (map approximate_ratio) (map cents_to_ratio) . ratios_or_cents --- | 'Maybe' exact ratios reconstructued from possibly inexact 'Cents' +-- | Cyclic form, taking into consideration 'octave_ratio'. +approximate_ratios_cyclic :: Tuning -> [Approximate_Ratio] +approximate_ratios_cyclic t = + let r = approximate_ratios t + m = realToFrac (octave_ratio t) + g = iterate (* m) 1 + f n = map (* n) r + in concatMap f g + +-- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents' -- of 'Tuning'. -- -- > let r = [1,17/16,9/8,13/11,5/4,4/3,7/5,3/2,11/7,5/3,16/9,15/8] @@ -78,34 +81,40 @@ reconstructed_ratios :: Double -> Tuning -> Maybe [Rational] reconstructed_ratios epsilon = fmap (map (reconstructed_ratio epsilon)) . - fromRight . + T.fromRight . ratios_or_cents --- | Convert from an 'Approximate_Ratio' to 'Cents'. +-- | Convert from a 'Floating' ratio to /cents/. -- --- > round (to_cents (3/2)) == 702 -to_cents :: Approximate_Ratio -> Cents -to_cents x = 1200 * logBase 2 x +-- > let r = [0,498,702,1200] +-- > in map (round . fratio_to_cents) [1,4/3,3/2,2] == r +fratio_to_cents :: (Real r,Floating n) => r -> n +fratio_to_cents = (1200 *) . logBase 2 . realToFrac --- | Convert from 'Rational' to 'Approximate_Ratio', ie. 'fromRational'. +-- | Type specialised 'fratio_to_cents'. +approximate_ratio_to_cents :: Approximate_Ratio -> Cents +approximate_ratio_to_cents = fratio_to_cents + +-- | Type specialised 'fromRational'. approximate_ratio :: Rational -> Approximate_Ratio approximate_ratio = fromRational --- | 'to_cents' '.' 'approximate_ratio'. -to_cents_r :: Rational -> Cents -to_cents_r = to_cents . approximate_ratio +-- | 'approximate_ratio_to_cents' '.' 'approximate_ratio'. +ratio_to_cents :: Rational -> Cents +ratio_to_cents = approximate_ratio_to_cents . approximate_ratio -- | Construct an exact 'Rational' that approximates 'Cents' to within -- /epsilon/. -- -- > map (reconstructed_ratio 1e-5) [0,700,1200] == [1,442/295,2] -- --- > to_cents_r (442/295) == 699.9976981706735 +-- > ratio_to_cents (442/295) == 699.9976981706734 reconstructed_ratio :: Double -> Cents -> Rational reconstructed_ratio epsilon c = approxRational (cents_to_ratio c) epsilon -- | Frequency /n/ cents from /f/. -- +-- > import Music.Theory.Pitch -- > map (cps_shift_cents 440) [-100,100] == map octpc_to_cps [(4,8),(4,10)] cps_shift_cents :: Floating a => a -> a -> a cps_shift_cents f = (* f) . cents_to_ratio @@ -117,8 +126,8 @@ -- -- > let abs_dif i j = abs (i - j) -- > in cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9 -cps_difference_cents :: Floating a => a -> a -> a -cps_difference_cents p q = ratio_to_cents (q / p) +cps_difference_cents :: (Real r,Fractional r,Floating n) => r -> r -> n +cps_difference_cents p q = fratio_to_cents (q / p) -- * Commas @@ -142,7 +151,7 @@ -- | Calculate /n/th root of /x/. -- --- > 12 `nth_root` 2 == twelve_tone_equal_temperament_comma +-- > 12 `nth_root` 2 == twelve_tone_equal_temperament_comma nth_root :: (Floating a,Eq a) => a -> a -> a nth_root n x = let f (_,x0) = (x0, ((n-1)*x0+x/x0**(n-1))/n) @@ -155,422 +164,49 @@ twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a twelve_tone_equal_temperament_comma = 12 `nth_root` 2 --- * 12-tone tunings - --- > let c = [0,114,204,294,408,498,612,702,816,906,996,1110] --- > in map (round.to_cents_r) ditone_r == c -ditone_r :: [Rational] -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 ditone == [0,114,204,294,408,498,612,702,816,906,996,1110] -ditone :: Tuning -ditone = Tuning (Left ditone_r) 2 - --- > let c = [0,90,204,294,408,498,612,702,792,906,996,1110] --- > in map (round.to_cents_r) 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. --- --- > cents_i pythagorean == [0,90,204,294,408,498,612,702,792,906,996,1110] -pythagorean :: Tuning -pythagorean = Tuning (Left pythagorean_r) 2 - --- > let c = [0,90,192,294,390,498,588,696,792,888,996,1092] --- > in map (round.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] - -werckmeister_iii_c :: [Cents] -werckmeister_iii_c = map 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_c) 2 - --- > let c = [0,82,196,294,392,498,588,694,784,890,1004,1086] --- > in map (round.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] - -werckmeister_iv_c :: [Cents] -werckmeister_iv_c = map 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 - --- > let c = [0,96,204,300,396,504,600,702,792,900,1002,1098] --- > in map (round.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] - -werckmeister_v_c :: [Cents] -werckmeister_v_c = map 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 - --- > let c = [0,91,196,298,395,498,595,698,793,893,1000,1097] --- > in map (round.to_cents_r) 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 - --- > 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 - --- > 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 - --- > let c = [0,112,204,316,386,498,590,702,814,884,996,1088] --- > in map (round.to_cents_r) 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 - ,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 - --- > equal_temperament_c == [0,100..1100] -equal_temperament_c :: [Cents] -equal_temperament_c = [0, 100 .. 1100] - --- | Equal temperament. --- --- > cents equal_temperament == [0,100..1100] -equal_temperament :: Tuning -equal_temperament = Tuning (Right equal_temperament_c) 2 - --- > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088] --- > in map (round.to_cents_r) 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] - --- > 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 - --- > let c = [0,112,204,316,386,498,583,702,814,884,969,1088] --- > in map (round.to_cents_r) 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] - --- > 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 - --- > 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 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] - --- > 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.to_cents_r) 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] - --- > 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 - --- > let c = [0,177,204,240,471,444,675,702,738,969,942,1173] --- > in map (round.to_cents_r) 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 - --- > let c = [0,105,204,298,386,471,551,702,841,906,969,1088] --- > in map (round.to_cents_r) 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 - --- > let c = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088] --- > in map (round.to_cents_r) 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 --- --- --- > cents_i lou_harrison_16 == [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088] -lou_harrison_16 :: Tuning -lou_harrison_16 = Tuning (Left lou_harrison_16_r) 2 - -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 - --- * Syntonic tuning +-- * Equal temperaments --- | Construct an isomorphic layout of /r/ rows and /c/ columns with --- an upper left value of /(i,j)/. -mk_isomorphic_layout :: Integral a => a -> a -> (a,a) -> [[(a,a)]] -mk_isomorphic_layout n_row n_col top_left = - let (a,b) `plus` (c,d) = (a+c,b+d) - mk_seq 0 _ _ = [] - mk_seq n i z = z : mk_seq (n-1) i (z `plus` i) - left = mk_seq n_row (-1,1) top_left - in map (mk_seq n_col (-1,2)) left +-- | Make /n/ division equal temperament. +equal_temperament :: Integral n => n -> Tuning +equal_temperament n = + let c = genericTake n [0,1200 / fromIntegral n ..] + in Tuning (Right c) 2 --- | A minimal isomorphic note layout. +-- | 12-tone equal temperament. -- --- > let [i,j,k] = mk_isomorphic_layout 3 5 (3,-4) --- > in [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout -minimal_isomorphic_note_layout :: [[(Int,Int)]] -minimal_isomorphic_note_layout = - [[(3,-4),(2,-2),(1,0),(0,2),(-1,4)] - ,[(2,-3),(1,-1),(0,1),(-1,3)] - ,[(2,-4),(1,-2),(0,0),(-1,2),(-2,4)]] +-- > cents equal_temperament_12 == [0,100..1100] +equal_temperament_12 :: Tuning +equal_temperament_12 = equal_temperament (12::Int) --- | Make a rank two regular temperament from a list of /(i,j)/ --- positions by applying the scalars /a/ and /b/. -rank_two_regular_temperament :: Integral a => a -> a -> [(a,a)] -> [a] -rank_two_regular_temperament a b = let f (i,j) = i * a + j * b in map f +-- | 19-tone equal temperament. +equal_temperament_19 :: Tuning +equal_temperament_19 = equal_temperament (19::Int) --- | Syntonic tuning system based on 'mk_isomorphic_layout' of @5@ --- rows and @7@ columns starting at @(3,-4)@ and a --- 'rank_two_regular_temperament' with /a/ of @1200@ and indicated --- /b/. -mk_syntonic_tuning :: Int -> [Cents] -mk_syntonic_tuning b = - let l = mk_isomorphic_layout 5 7 (3,-4) - t = map (rank_two_regular_temperament 1200 b) l - in nub (sort (map (\x -> fromIntegral (x `mod` 1200)) (concat t))) +-- | 31-tone equal temperament. +equal_temperament_31 :: Tuning +equal_temperament_31 = equal_temperament (31::Int) --- | 'mk_syntonic_tuning' of @697@. --- --- > divisions syntonic_697 == 17 --- > cents_i syntonic_697 == [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164] -syntonic_697 :: Tuning -syntonic_697 = Tuning (Right (mk_syntonic_tuning 697)) 2 +-- | 53-tone equal temperament. +equal_temperament_53 :: Tuning +equal_temperament_53 = equal_temperament (53::Int) --- | 'mk_syntonic_tuning' of @702@. +-- | 72-tone equal temperament. -- --- > divisions syntonic_702 == 17 --- > cents_i syntonic_702 == [0,24,114,204,294,318,408,498,522,612,702,792,816,906,996,1020,1110] -syntonic_702 :: Tuning -syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) 2 +-- > let r = [0,17,33,50,67,83,100] +-- > in take 7 (map round (cents equal_temperament_72)) == r +equal_temperament_72 :: Tuning +equal_temperament_72 = equal_temperament (72::Int) -- * Harmonic series -- | Raise or lower the frequency /q/ by octaves until it is in the -- octave starting at /p/. -- --- > fold_to_octave_of 55 392 == 98 +-- > 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 q = - if q > p * 2 - then fold_cps_to_octave_of p (q / 2) - else if q < p - then fold_cps_to_octave_of p (q * 2) - else q +fold_cps_to_octave_of p = + let f q = if q > p * 2 then f (q / 2) else if q < p then f (q * 2) else q + in f -- | Harmonic series on /n/. harmonic_series_cps :: (Num t, Enum t) => t -> [t] @@ -578,17 +214,31 @@ -- | /n/ elements of 'harmonic_series_cps'. -- --- > harmonic_series_cps_n 14 55 == [55,110,165,220,275,330,385,440,495,550,605,660,715,770] +-- > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935] +-- > in harmonic_series_cps_n 17 55 == r harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a] harmonic_series_cps_n n = take n . harmonic_series_cps +-- | Sub-harmonic series on /n/. +subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t] +subharmonic_series_cps n = map (* n) (map recip [1..]) + +-- | /n/ elements of 'harmonic_series_cps'. +-- +-- > let r = [1760,880,587,440,352,293,251,220,196,176,160,147,135,126,117,110,104] +-- > in map round (subharmonic_series_cps_n 17 1760) == r +subharmonic_series_cps_n :: (Fractional t,Enum t) => Int -> t -> [t] +subharmonic_series_cps_n n = take n . subharmonic_series_cps + -- | /n/th partial of /f1/, ie. one indexed. -- -- > map (partial 55) [1,5,3] == [55,275,165] partial :: (Num a, Enum a) => a -> Int -> a -partial f1 k = harmonic_series_cps f1 !! (k - 1) +partial f1 k = harmonic_series_cps f1 `at` (k - 1) -- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@. +-- +-- > map fold_ratio_to_octave [2/3,3/4] == [4/3,3/2] fold_ratio_to_octave :: Integral i => Ratio i -> Ratio i fold_ratio_to_octave n = if n >= 2 @@ -597,8 +247,21 @@ then fold_ratio_to_octave (n * 2) else n +-- | The interval between two pitches /p/ and /q/ given as ratio +-- multipliers of a fundamental is /q/ '/' /p/. The classes over such +-- intervals consider the 'fold_ratio_to_octave' of both /p/ to /q/ +-- and /q/ to /p/. +-- +-- > map ratio_interval_class [2/3,3/2,3/4,4/3] == [3/2,3/2,3/2,3/2] +ratio_interval_class :: Integral i => Ratio i -> Ratio i +ratio_interval_class i = + let f = fold_ratio_to_octave + in max (f i) (f (recip i)) + -- | Derivative harmonic series, based on /k/th partial of /f1/. -- +-- > import Music.Theory.Pitch +-- -- > let {r = [52,103,155,206,258,309,361,412,464,515,567,618,670,721,773] -- > ;d = harmonic_series_cps_derived 5 (octpc_to_cps (1,4))} -- > in map round (take 15 d) == r @@ -610,21 +273,122 @@ -- | Harmonic series to /n/th harmonic (folded). -- -- > harmonic_series_folded 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8] +-- +-- > let r = [0,105,204,386,551,702,841,969,1088] +-- > in map (round . ratio_to_cents) (harmonic_series_folded 17) == r harmonic_series_folded :: Integer -> [Rational] harmonic_series_folded n = nub (sort (map fold_ratio_to_octave [1 .. n%1])) --- | 'to_cents_r' variant of 'harmonic_series_folded'. +-- | '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 to_cents_r . harmonic_series_folded +harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded -- | @12@-tone tuning of first @21@ elements of the harmonic series. -- -- > cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088] +-- > divisions harmonic_series_folded_21 == 11 harmonic_series_folded_21 :: Tuning harmonic_series_folded_21 = Tuning (Left (harmonic_series_folded 21)) 2 + +-- * Cents + +-- | Give cents difference from nearest 12ET tone. +-- +-- > let r = [50,-49,-2,0,2,49,50] +-- > in map cents_et12_diff [650,651,698,700,702,749,750] == r +cents_et12_diff :: Integral n => n -> n +cents_et12_diff n = + let m = n `mod` 100 + in if m > 50 then m - 100 else m + +-- | Fractional form of 'cents_et12_diff'. +fcents_et12_diff :: Real n => n -> n +fcents_et12_diff n = + let m = n `mod'` 100 + in if m > 50 then m - 100 else m + +-- | The class of cents intervals has range @(0,600)@. +-- +-- > map cents_interval_class [50,1150,1250] == [50,50,50] +-- +-- > let r = concat [[0,50 .. 550],[600],[550,500 .. 0]] +-- > in map cents_interval_class [1200,1250 .. 2400] == r +cents_interval_class :: Integral a => a -> a +cents_interval_class n = + let n' = n `mod` 1200 + in if n' > 600 then 1200 - n' else n' + +-- | Fractional form of 'cents_interval_class'. +fcents_interval_class :: Real a => a -> a +fcents_interval_class n = + let n' = n `mod'` 1200 + in if n' > 600 then 1200 - n' else n' + +-- | Always include the sign, elide @0@. +cents_diff_pp :: (Num a, Ord a, Show a) => a -> String +cents_diff_pp n = + case compare n 0 of + LT -> show n + EQ -> "" + GT -> '+' : show n + +-- | Given brackets, print cents difference. +cents_diff_br :: (Num a, Ord a, Show a) => (String,String) -> a -> String +cents_diff_br br = + let f s = if null s then s else T.bracket_l br s + in f . cents_diff_pp + +-- | 'cents_diff_br' with parentheses. +-- +-- > map cents_diff_text [-1,0,1] == ["(-1)","","(+1)"] +cents_diff_text :: (Num a, Ord a, Show a) => a -> String +cents_diff_text = cents_diff_br ("(",")") + +-- | 'cents_diff_br' with markdown superscript (@^@). +cents_diff_md :: (Num a, Ord a, Show a) => a -> String +cents_diff_md = cents_diff_br ("^","^") + +-- | 'cents_diff_br' with HTML superscript (@@). +cents_diff_html :: (Num a, Ord a, Show a) => a -> String +cents_diff_html = cents_diff_br ("","") + +-- * Midi + +-- | (/n/ -> /dt/). Function from midi note number /n/ to +-- 'Midi_Detune' /dt/. The incoming note number is the key pressed, +-- which may be distant from the note sounded. +type Midi_Tuning_F = Int -> T.Midi_Detune + +-- | (t,c,k) where t=tuning (must have 12 divisions of octave), +-- c=cents deviation (ie. constant detune offset), k=midi offset +-- (ie. value to be added to incoming midi note number). +type D12_Midi_Tuning = (Tuning,Cents,Int) + +-- | 'Midi_Tuning_F' for 'D12_Midi_Tuning'. +-- +-- > import Music.Theory.Tuning.Gann +-- > let f = d12_midi_tuning_f (la_monte_young,-74.7,-3) +-- > octpc_to_midi (-1,11) == 11 +-- > map (round . midi_detune_to_cps . f) [62,63,69] == [293,298,440] +d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_F +d12_midi_tuning_f (t,c_diff,k) n = + let (_,pc) = T.midi_to_octpc (n + k) + dt = zipWith (-) (cents t) [0,100 .. 1200] + in (n,(dt `at` pc) + c_diff) + +-- | (t,f0,k) where t=tuning, f0=fundamental frequency, k=midi note +-- number for f0, n=gamut +type CPS_Midi_Tuning = (Tuning,Double,Int,Int) + +-- | 'Midi_Tuning_F' for 'CPS_Midi_Tuning'. +cps_midi_tuning_f :: CPS_Midi_Tuning -> Midi_Tuning_F +cps_midi_tuning_f (t,f0,k,g) n = + let r = approximate_ratios_cyclic t + m = take g (map (T.cps_to_midi_detune . (* f0)) r) + in m `at` (n - k) -- Local Variables: -- truncate-lines:t diff --git a/Music/Theory/Tuning/Alves.hs b/Music/Theory/Tuning/Alves.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Alves.hs @@ -0,0 +1,25 @@ +-- | 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/ET.hs b/Music/Theory/Tuning/ET.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/ET.hs @@ -0,0 +1,248 @@ +-- | Equal temperament tuning tables. +module Music.Theory.Tuning.ET where + +import Data.List {- base -} +import Data.List.Split {- split -} +import Data.Ratio {- base -} +import Text.Printf {- base -} + +import Music.Theory.List {- hmt -} +import Music.Theory.Pitch {- hmt -} +import Music.Theory.Pitch.Note {- hmt -} +import Music.Theory.Pitch.Spelling {- hmt -} +import Music.Theory.Tuning {- hmt -} + +-- | 'octpc_to_pitch' and 'octpc_to_cps'. +octpc_to_pitch_cps :: (Floating n) => OctPC -> (Pitch,n) +octpc_to_pitch_cps x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps x) + +-- | 12-tone equal temperament table equating 'Pitch' and frequency +-- over range of human hearing, where @A4@ = @440@hz. +-- +-- > length tbl_12et == 132 +-- > let min_max l = (minimum l,maximum l) +-- > min_max (map (round . snd) tbl_12et) == (16,31609) +tbl_12et :: [(Pitch,Double)] +tbl_12et = + let z = [(o,pc) | o <- [0..10], pc <- [0..11]] + in map octpc_to_pitch_cps z + +-- | 24-tone equal temperament variant of 'tbl_12et'. +-- +-- > length tbl_24et == 264 +-- > min_max (map (round . snd) tbl_24et) == (16,32535) +tbl_24et :: [(Pitch,Double)] +tbl_24et = + let f x = let p = fmidi_to_pitch pc_spell_ks x + p' = pitch_rewrite_threequarter_alteration p + in (p',fmidi_to_cps x) + in map f [12,12.5 .. 143.5] + +-- | Given an @ET@ table (or like) find bounds of frequency. +-- +-- > let r = Just (at_pair octpc_to_pitch_cps ((3,11),(4,0))) +-- > in bounds_et_table tbl_12et 256 == r +bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s)) +bounds_et_table tbl = + let f (_,p) = compare p + in find_bounds True f tbl + +-- | 'bounds_et_table' of 'tbl_12et'. +-- +-- > map bounds_12et_tone (hsn 17 55) +bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double)) +bounds_12et_tone = bounds_et_table tbl_12et + +-- | Tuple indicating nearest 'Pitch' to /frequency/ with @ET@ +-- frequency, and deviation in hertz and 'Cents'. +type HS_R p = (Double,p,Double,Double,Cents) + +-- | /n/-decimal places. +-- +-- > ndp 3 (1/3) == "0.333" +ndp :: Int -> Double -> String +ndp = printf "%.*f" + +-- | Pretty print 'HS_R'. +hs_r_pp :: (p -> String) -> Int -> HS_R p -> [String] +hs_r_pp pp n (f,p,pf,fd,c) = + let dp = ndp n + in [dp f + ,pp p + ,dp pf + ,dp fd + ,dp c] + +hs_r_pitch_pp :: Int -> HS_R Pitch -> [String] +hs_r_pitch_pp = hs_r_pp pitch_pp + +-- | Form 'HS_R' for /frequency/ by consulting table. +-- +-- > let {f = 256 +-- > ;f' = octpc_to_cps (4,0) +-- > ;r = (f,Pitch C Natural 4,f',f-f',fratio_to_cents (f/f'))} +-- > in nearest_et_table_tone tbl_12et 256 == r +nearest_et_table_tone :: [(p,Double)] -> Double -> HS_R p +nearest_et_table_tone tbl f = + case bounds_et_table tbl f of + Nothing -> error "nearest_et_table_tone: no bounds?" + Just ((lp,lf),(rp,rf)) -> + let ld = f - lf + rd = f - rf + in if abs ld < abs rd + then (f,lp,lf,ld,fratio_to_cents (f/lf)) + else (f,rp,rf,rd,fratio_to_cents (f/rf)) + +-- | 'nearest_et_table_tone' for 'tbl_12et'. +nearest_12et_tone :: Double -> HS_R Pitch +nearest_12et_tone = nearest_et_table_tone tbl_12et + +-- | 'nearest_et_table_tone' for 'tbl_24et'. +-- +-- > let r = "55.0 A1 55.0 0.0 0.0" +-- > in unwords (hs_r_pitch_pp 1 (nearest_24et_tone 55)) == r +nearest_24et_tone :: Double -> HS_R Pitch +nearest_24et_tone = nearest_et_table_tone tbl_24et + +-- * 72ET + +-- | Monzo 72-edo HEWM notation. The domain is (-9,9). +-- +-- +-- > let r = ["+",">","^","#<","#-","#","#+","#>","#^"] +-- > in map alteration_72et_monzo [1 .. 9] == r +-- +-- > let r = ["-","<","v","b>","b+","b","b-","b<","bv"] +-- > in map alteration_72et_monzo [-1,-2 .. -9] == r +alteration_72et_monzo :: Integral n => n -> String +alteration_72et_monzo n = + let spl = splitOn "," + asc = spl ",+,>,^,#<,#-,#,#+,#>,#^" + dsc = spl ",-,<,v,b>,b+,b,b-,b<,bv" + in case compare n 0 of + LT -> genericIndex dsc (- n) + EQ -> "" + GT -> genericIndex asc n + +-- | Given a midi note number and @1/6@ deviation determine 'Pitch'' +-- and frequency. +-- +-- > let {f = pitch'_pp . fst . pitch_72et +-- > ;r = "C4 C+4 C>4 C^4 C#<4 C#-4 C#4 C#+4 C#>4 C#^4"} +-- > in unwords (map f (zip (repeat 60) [0..9])) == r +-- +-- > let {f = pitch'_pp . fst . pitch_72et +-- > ;r = "A4 A+4 A>4 A^4 Bb<4 Bb-4 Bb4 Bb+4 Bb>4 Bv4"} +-- > in unwords (map f (zip (repeat 69) [0..9])) +-- +-- > let {f = pitch'_pp . fst . pitch_72et +-- > ;r = "Bb4 Bb+4 Bb>4 Bv4 B<4 B-4 B4 B+4 B>4 B^4"} +-- > in unwords (map f (zip (repeat 70) [0..9])) == r +pitch_72et :: (Int,Int) -> (Pitch',Double) +pitch_72et (x,n) = + let p = midi_to_pitch pc_spell_ks x + t = note p + a = alteration p + (t',n') = case a of + Flat -> if n < (-3) then (pred t,n + 6) else (t,n - 6) + Natural -> (t,n) + Sharp -> if n > 3 then (succ t,n - 6) else (t,n + 6) + _ -> error "pitch_72et: alteration?" + a' = alteration_72et_monzo n' + x' = fromIntegral x + (fromIntegral n / 6) + r = (Pitch' t' (fromIntegral n' % 12,a') (octave p),fmidi_to_cps x') + r' = if n > 3 + then pitch_72et (x + 1,n - 6) + else if n < (-3) + then pitch_72et (x - 1,n + 6) + else r + in case a of + Natural -> r' + _ -> r + +-- | 72-tone equal temperament table equating 'Pitch'' and frequency +-- over range of human hearing, where @A4@ = @440@hz. +-- +-- > length tbl_72et == 792 +-- > min_max (map (round . snd) tbl_72et) == (16,33167) +tbl_72et :: [(Pitch',Double)] +tbl_72et = + let f n = map pitch_72et (zip (replicate 6 n) [0..5]) + in concatMap f [12 .. 143] + +-- | 'nearest_et_table_tone' for 'tbl_72et'. +-- +-- > let r = "324.0 E<4 323.3 0.7 3.5" +-- > in unwords (hs_r_pp pitch'_pp 1 (nearest_72et_tone 324)) +-- +-- > let {f = take 2 . hs_r_pp pitch'_pp 1 . nearest_72et_tone . snd} +-- > in mapM_ (print . unwords . f) tbl_72et +nearest_72et_tone :: Double -> HS_R Pitch' +nearest_72et_tone = nearest_et_table_tone tbl_72et + +-- * Detune + +-- | 'Pitch' with 12-ET/24-ET tuning deviation given in 'Cents'. +type Pitch_Detune = (Pitch,Cents) + +-- | Exract 'Pitch_Detune' from 'HS_R'. +hsr_to_pitch_detune :: HS_R Pitch -> Pitch_Detune +hsr_to_pitch_detune (_,p,_,_,c) = (p,c) + +-- | Nearest 12-ET 'Pitch_Detune' to indicated frequency (hz). +-- +-- > nearest_pitch_detune_12et 452.8929841231365 +nearest_pitch_detune_12et :: Double -> Pitch_Detune +nearest_pitch_detune_12et = hsr_to_pitch_detune . nearest_12et_tone + +-- | Nearest 24-ET 'Pitch_Detune' to indicated frequency (hz). +-- +-- > nearest_pitch_detune_24et 452.8929841231365 +nearest_pitch_detune_24et :: Double -> Pitch_Detune +nearest_pitch_detune_24et = hsr_to_pitch_detune . nearest_24et_tone + +-- | Given /near/ function, /f0/ and ratio derive 'Pitch_Detune'. +ratio_to_pitch_detune :: (Double -> HS_R Pitch) -> OctPC -> Rational -> Pitch_Detune +ratio_to_pitch_detune near_f f0 r = + let f = octpc_to_cps f0 * realToFrac r + (_,p,_,_,c) = near_f f + in (p,c) + +-- | Frequency (hz) of 'Pitch_Detune'. +-- +-- > pitch_detune_to_cps (octpc_to_pitch pc_spell_ks (4,9),50) +pitch_detune_to_cps :: Floating n => Pitch_Detune -> n +pitch_detune_to_cps (p,d) = cps_shift_cents (pitch_to_cps p) (realToFrac d) + +-- | 'ratio_to_pitch_detune' of 'nearest_12et_tone' +ratio_to_pitch_detune_12et :: OctPC -> Rational -> Pitch_Detune +ratio_to_pitch_detune_12et = ratio_to_pitch_detune nearest_12et_tone + +-- | 'ratio_to_pitch_detune' of 'nearest_24et_tone' +ratio_to_pitch_detune_24et :: OctPC -> Rational -> Pitch_Detune +ratio_to_pitch_detune_24et = ratio_to_pitch_detune nearest_24et_tone + +pitch_detune_in_octave_nearest :: Pitch -> Pitch_Detune -> Pitch_Detune +pitch_detune_in_octave_nearest p1 (p2,d2) = + let p2' = pitch_in_octave_nearest p1 p2 + in (p2',d2) + +-- | Markdown pretty-printer for 'Pitch_Detune'. +pitch_detune_md :: Pitch_Detune -> String +pitch_detune_md (p,c) = + pitch_pp p ++ cents_diff_md (round c :: Integer) + +-- | HTML pretty-printer for 'Pitch_Detune'. +pitch_detune_html :: Pitch_Detune -> String +pitch_detune_html (p,c) = + pitch_pp p ++ cents_diff_html (round c :: Integer) + +-- | No-octave variant of 'pitch_detune_md'. +pitch_class_detune_md :: Pitch_Detune -> String +pitch_class_detune_md (p,c) = + pitch_class_pp p ++ cents_diff_md (round c :: Integer) + +-- | No-octave variant of 'pitch_detune_html'. +pitch_class_detune_html :: Pitch_Detune -> String +pitch_class_detune_html (p,c) = + pitch_class_pp p ++ cents_diff_html (round c :: Integer) diff --git a/Music/Theory/Tuning/Gann.hs b/Music/Theory/Tuning/Gann.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Gann.hs @@ -0,0 +1,141 @@ +-- | 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/Microtonal_Synthesis.hs b/Music/Theory/Tuning/Microtonal_Synthesis.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Microtonal_Synthesis.hs @@ -0,0 +1,205 @@ +-- | +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_1984.hs b/Music/Theory/Tuning/Polansky_1984.hs --- a/Music/Theory/Tuning/Polansky_1984.hs +++ b/Music/Theory/Tuning/Polansky_1984.hs @@ -144,9 +144,9 @@ i' = 21/16 * v in [1,8/7,21/16,v,vi,i'] --- | 'to_cents_r' of 'polansky_1984_r'. +-- | 'ratio_to_cents' of 'polansky_1984_r'. -- -- > import Music.Theory.List -- > map round (d_dx polansky_1984_c) == [231,240,223,240,231] polansky_1984_c :: [Cents] -polansky_1984_c = map to_cents_r polansky_1984_r +polansky_1984_c = map ratio_to_cents polansky_1984_r diff --git a/Music/Theory/Tuning/Polansky_1985c.hs b/Music/Theory/Tuning/Polansky_1985c.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Polansky_1985c.hs @@ -0,0 +1,35 @@ +-- | Larry Polansky. "Notes on Piano Study #5". +-- _1/1, The Journal of the Just Intonation Newtork_, 1(4), Autumn 1985. +module Music.Theory.Tuning.Polansky_1985c where + +import Music.Theory.Tuning {- hmt -} + +-- | The tuning has four octaves, these ratios are per-octave. +ps5_jpr_r :: [[Rational]] +ps5_jpr_r = + [[1/1, 21/20, 9/8, 6/5, 5/4, 4/3, 7/5, 3/2, 8/5, 5/3, 7/4, 15/8] + ,[1/1, 21/20, 9/8, 6/5, 5/4, 4/3, 7/5, 3/2, 8/5, 5/3, 7/4, 15/8] + ,[1/1, 33/32, 9/8, 6/5, 5/4, 21/16, 11/8, 3/2, 8/5, 13/8, 7/4, 15/8] + ,[1/1, 21/20, 9/8, 7/6, 5/4, 4/3, 11/8, 3/2, 8/5, 27/16, 7/4, 15/8]] + +{- | Four-octave tuning. + +> import Data.List.Split + +> let r = [[ 0, 84, 204, 316, 386, 498, 583, 702, 814, 884, 969,1088] +> ,[1200,1284,1404,1516,1586,1698,1783,1902,2014,2084,2169,2288] +> ,[2400,2453,2604,2716,2786,2871,2951,3102,3214,3241,3369,3488] +> ,[3600,3684,3804,3867,3986,4098,4151,4302,4414,4506,4569,4688]] +> in chunksOf 12 (cents_i ps5_jpr) == r + +> let r = [[0,84,204,316,386,498,583,702,814,884,969,1088] +> ,[0,84,204,316,386,498,583,702,814,884,969,1088] +> ,[0,53,204,316,386,471,551,702,814,841,969,1088] +> ,[0,84,204,267,386,498,551,702,814,906,969,1088]] +> chunksOf 12 (map (`mod` 1200) (cents_i ps5_jpr)) +-} +ps5_jpr :: Tuning +ps5_jpr = + let f (m,n) = map (* m) n + r = concat (map f (zip [1,2,4,8] ps5_jpr_r)) + in Tuning (Left r) 16 diff --git a/Music/Theory/Tuning/Riley.hs b/Music/Theory/Tuning/Riley.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Riley.hs @@ -0,0 +1,18 @@ +-- | 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/Scala.hs b/Music/Theory/Tuning/Scala.hs --- a/Music/Theory/Tuning/Scala.hs +++ b/Music/Theory/Tuning/Scala.hs @@ -1,6 +1,6 @@ -- | Parser for the Scala scale file format. See -- for details. --- This module succesfully parses all 4115 scales in v.77 of the scale +-- This module succesfully parses all 4496 scales in v.81 of the scale -- library. module Music.Theory.Tuning.Scala where @@ -56,7 +56,7 @@ pitch_cents p = case p of Left c -> c - Right r -> T.to_cents_r r + Right r -> T.ratio_to_cents r type Epsilon = Double @@ -149,7 +149,7 @@ -- | Load @.scl@ file. -- --- > s <- load "/home/rohan/opt/scala/scl/xenakis_chrom.scl" +-- > 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) @@ -167,12 +167,12 @@ -- | Load all @.scl@ files at /dir/. -- --- > db <- load_dir "/home/rohan/opt/scala/scl" --- > length db == 4115 --- > length (filter ((== 0) . scale_degree) db) == 1 --- > length (filter (== Just (Right 2)) (map scale_octave db)) == 3562 +-- > db <- load_dir "/home/rohan/data/scala/81/scl" +-- > length db == 4496 +-- > length (filter ((== 0) . scale_degree) db) == 0 +-- > length (filter (== Just (Right 2)) (map scale_octave db)) == 3855 -- --- > let r = [0,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24 +-- > 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 diff --git a/Music/Theory/Tuning/Syntonic.hs b/Music/Theory/Tuning/Syntonic.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Syntonic.hs @@ -0,0 +1,60 @@ +-- | Syntonic tuning. +module Music.Theory.Tuning.Syntonic where + +import Data.List {- base -} + +import Music.Theory.Tuning {- hmt -} + +-- | Construct an isomorphic layout of /r/ rows and /c/ columns with +-- an upper left value of /(i,j)/. +mk_isomorphic_layout :: Integral a => a -> a -> (a,a) -> [[(a,a)]] +mk_isomorphic_layout n_row n_col top_left = + let (a,b) `plus` (c,d) = (a+c,b+d) + mk_seq 0 _ _ = [] + mk_seq n i z = z : mk_seq (n-1) i (z `plus` i) + left = mk_seq n_row (-1,1) top_left + in map (mk_seq n_col (-1,2)) left + +-- | A minimal isomorphic note layout. +-- +-- > let [i,j,k] = mk_isomorphic_layout 3 5 (3,-4) +-- > in [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout +minimal_isomorphic_note_layout :: [[(Int,Int)]] +minimal_isomorphic_note_layout = + [[(3,-4),(2,-2),(1,0),(0,2),(-1,4)] + ,[(2,-3),(1,-1),(0,1),(-1,3)] + ,[(2,-4),(1,-2),(0,0),(-1,2),(-2,4)]] + +-- | Make a rank two regular temperament from a list of /(i,j)/ +-- positions by applying the scalars /a/ and /b/. +rank_two_regular_temperament :: Integral a => a -> a -> [(a,a)] -> [a] +rank_two_regular_temperament a b = let f (i,j) = i * a + j * b in map f + +-- | Syntonic tuning system based on 'mk_isomorphic_layout' of @5@ +-- rows and @7@ columns starting at @(3,-4)@ and a +-- 'rank_two_regular_temperament' with /a/ of @1200@ and indicated +-- /b/. +mk_syntonic_tuning :: Int -> [Cents] +mk_syntonic_tuning b = + let l = mk_isomorphic_layout 5 7 (3,-4) + t = map (rank_two_regular_temperament 1200 b) l + in nub (sort (map (\x -> fromIntegral (x `mod` 1200)) (concat t))) + +-- | 'mk_syntonic_tuning' of @697@. +-- +-- > divisions syntonic_697 == 17 +-- +-- > let c = [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164] +-- > in cents_i syntonic_697 == c +syntonic_697 :: Tuning +syntonic_697 = Tuning (Right (mk_syntonic_tuning 697)) 2 + +-- | 'mk_syntonic_tuning' of @702@. +-- +-- > divisions syntonic_702 == 17 +-- +-- > let c = [0,24,114,204,294,318,408,498,522,612,702,792,816,906,996,1020,1110] +-- > in cents_i syntonic_702 == c +syntonic_702 :: Tuning +syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) 2 + diff --git a/Music/Theory/Tuning/Werckmeister.hs b/Music/Theory/Tuning/Werckmeister.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Werckmeister.hs @@ -0,0 +1,105 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuple.hs @@ -0,0 +1,258 @@ +-- | Tuple functions. +-- +-- Uniform tuples have types 'T2', 'T3' etc. and functions names are +-- prefixed @t2_@ etc. +-- +-- Heterogenous tuples (products) are prefixed @p2_@ etc. +module Music.Theory.Tuple where + +import Data.Monoid {- base -} + +-- * P2 (2 product) + +p2_swap :: (s,t) -> (t,s) +p2_swap (i,j) = (j,i) + +-- * T2 (2-tuple, regular) + +-- | Uniform two-tuple. +type T2 a = (a,a) + +t2 :: [t] -> T2 t +t2 l = case l of {[p,q] -> (p,q);_ -> error "t2"} + +t2_list :: T2 a -> [a] +t2_list (i,j) = [i,j] + +t2_swap :: T2 t -> T2 t +t2_swap = p2_swap + +t2_map :: (p -> q) -> T2 p -> T2 q +t2_map f (p,q) = (f p,f q) + +t2_zipWith :: (p -> q -> r) -> T2 p -> T2 q -> T2 r +t2_zipWith f (p,q) (p',q') = (f p p',f q q') + +t2_infix :: (a -> a -> b) -> T2 a -> b +t2_infix f (i,j) = i `f` j + +-- | Infix 'mappend'. +-- +-- > t2_join ([1,2],[3,4]) == [1,2,3,4] +t2_join :: Monoid m => T2 m -> m +t2_join = t2_infix mappend + +t2_concat :: [T2 [a]] -> T2 [a] +t2_concat = t2_map mconcat . unzip + +t2_sort :: Ord t => (t,t) -> (t,t) +t2_sort (p,q) = (min p q,max p q) + +-- * P3 (3 product) + +-- | Left rotation. +-- +-- > p3_rotate_left (1,2,3) == (2,3,1) +p3_rotate_left :: (s,t,u) -> (t,u,s) +p3_rotate_left (i,j,k) = (j,k,i) + +p3_fst :: (a,b,c) -> a +p3_fst (a,_,_) = a + +p3_snd :: (a,b,c) -> b +p3_snd (_,b,_) = b + +p3_third :: (a,b,c) -> c +p3_third (_,_,c) = c + +-- * T3 (3 triple, regular) + +type T3 a = (a,a,a) + +t3 :: [t] -> T3 t +t3 l = case l of {[p,q,r] -> (p,q,r);_ -> error "t3"} + +t3_rotate_left :: T3 t -> T3 t +t3_rotate_left = p3_rotate_left + +t3_fst :: T3 t -> t +t3_fst = p3_fst + +t3_snd :: T3 t -> t +t3_snd = p3_snd + +t3_third :: T3 t -> t +t3_third = p3_third + +t3_map :: (p -> q) -> T3 p -> T3 q +t3_map f (p,q,r) = (f p,f q,f r) + +t3_zipWith :: (p -> q -> r) -> T3 p -> T3 q -> T3 r +t3_zipWith f (p,q,r) (p',q',r') = (f p p',f q q',f r r') +t3_list :: T3 a -> [a] +t3_list (i,j,k) = [i,j,k] + +t3_infix :: (a -> a -> a) -> T3 a -> a +t3_infix f (i,j,k) = (i `f` j) `f` k + +t3_join :: T3 [a] -> [a] +t3_join = t3_infix (++) + +-- * P4 (4 product) + +p4_fst :: (a,b,c,d) -> a +p4_fst (a,_,_,_) = a + +p4_snd :: (a,b,c,d) -> b +p4_snd (_,b,_,_) = b + +p4_third :: (a,b,c,d) -> c +p4_third (_,_,c,_) = c + +p4_fourth :: (a,b,c,d) -> d +p4_fourth (_,_,_,d) = d + +-- * T4 (4-tuple, regular) + +type T4 a = (a,a,a,a) + +t4 :: [t] -> T4 t +t4 l = case l of {[p,q,r,s] -> (p,q,r,s); _ -> error "t4"} + +t4_list :: T4 t -> [t] +t4_list (p,q,r,s) = [p,q,r,s] + +t4_fst :: T4 t -> t +t4_fst = p4_fst + +t4_snd :: T4 t -> t +t4_snd = p4_snd + +t4_third :: T4 t -> t +t4_third = p4_third + +t4_fourth :: T4 t -> t +t4_fourth = p4_fourth + +t4_map :: (p -> q) -> T4 p -> T4 q +t4_map f (p,q,r,s) = (f p,f q,f r,f s) + +t4_zipWith :: (p -> q -> r) -> T4 p -> T4 q -> T4 r +t4_zipWith f (p,q,r,s) (p',q',r',s') = (f p p',f q q',f r r',f s s') + +t4_infix :: (a -> a -> a) -> T4 a -> a +t4_infix f (i,j,k,l) = ((i `f` j) `f` k) `f` l + +t4_join :: T4 [a] -> [a] +t4_join = t4_infix (++) + +-- * P5 (5 product) + +p5_fst :: (a,b,c,d,e) -> a +p5_fst (a,_,_,_,_) = a + +p5_snd :: (a,b,c,d,e) -> b +p5_snd (_,b,_,_,_) = b + +p5_third :: (a,b,c,d,e) -> c +p5_third (_,_,c,_,_) = c + +p5_fourth :: (a,b,c,d,e) -> d +p5_fourth (_,_,_,d,_) = d + +p5_fifth :: (a,b,c,d,e) -> e +p5_fifth (_,_,_,_,e) = e + +-- * T5 (5-tuple, regular) + +type T5 a = (a,a,a,a,a) + +t5 :: [t] -> T5 t +t5 l = case l of {[p,q,r,s,t] -> (p,q,r,s,t); _ -> error "t5"} + +t5_list :: T5 t -> [t] +t5_list (p,q,r,s,t) = [p,q,r,s,t] + +t5_map :: (p -> q) -> T5 p -> T5 q +t5_map f (p,q,r,s,t) = (f p,f q,f r,f s,f t) + +t5_fst :: T5 t -> t +t5_fst (p,_,_,_,_) = p + +t5_snd :: T5 t -> t +t5_snd (_,q,_,_,_) = q + +t5_fourth :: T5 t -> t +t5_fourth (_,_,_,t,_) = t + +t5_fifth :: T5 t -> t +t5_fifth (_,_,_,_,u) = u + +t5_infix :: (a -> a -> a) -> T5 a -> a +t5_infix f (i,j,k,l,m) = (((i `f` j) `f` k) `f` l) `f` m + +t5_join :: T5 [a] -> [a] +t5_join = t5_infix (++) + +-- * P6 (6 product) + +p6_fst :: (a,b,c,d,e,f) -> a +p6_fst (a,_,_,_,_,_) = a + +p6_snd :: (a,b,c,d,e,f) -> b +p6_snd (_,b,_,_,_,_) = b + +p6_third :: (a,b,c,d,e,f) -> c +p6_third (_,_,c,_,_,_) = c + +p6_fourth :: (a,b,c,d,e,f) -> d +p6_fourth (_,_,_,d,_,_) = d + +p6_fifth :: (a,b,c,d,e,f) -> e +p6_fifth (_,_,_,_,e,_) = e + +p6_sixth :: (a,b,c,d,e,f) -> f +p6_sixth (_,_,_,_,_,f) = f + +-- * T6 (6-tuple, regular) + +type T6 a = (a,a,a,a,a,a) + +t6 :: [t] -> T6 t +t6 l = case l of {[p,q,r,s,t,u] -> (p,q,r,s,t,u);_ -> error "t6"} + +t6_list :: T6 t -> [t] +t6_list (p,q,r,s,t,u) = [p,q,r,s,t,u] + +t6_map :: (p -> q) -> T6 p -> T6 q +t6_map f (p,q,r,s,t,u) = (f p,f q,f r,f s,f t,f u) + +-- * T7 (7-tuple, regular) + +type T7 a = (a,a,a,a,a,a,a) + +t7_list :: T7 t -> [t] +t7_list (p,q,r,s,t,u,v) = [p,q,r,s,t,u,v] + +t7_map :: (p -> q) -> T7 p -> T7 q +t7_map f (p,q,r,s,t,u,v) = (f p,f q,f r,f s,f t,f u,f v) + +-- * T8 (8-tuple, regular) + +type T8 a = (a,a,a,a,a,a,a,a) + +t8_list :: T8 t -> [t] +t8_list (p,q,r,s,t,u,v,w) = [p,q,r,s,t,u,v,w] + +t8_map :: (p -> q) -> T8 p -> T8 q +t8_map f (p,q,r,s,t,u,v,w) = (f p,f q,f r,f s,f t,f u,f v,f w) + +-- * T9 (9-tuple, regular) + +type T9 a = (a,a,a,a,a,a,a,a,a) + +t9_list :: T9 t -> [t] +t9_list (p,q,r,s,t,u,v,w,x) = [p,q,r,s,t,u,v,w,x] + +t9_map :: (p -> q) -> T9 p -> T9 q +t9_map f (p,q,r,s,t,u,v,w,x) = (f p,f q,f r,f s,f t,f u,f v,f w,f x) diff --git a/Music/Theory/Unicode.hs b/Music/Theory/Unicode.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Unicode.hs @@ -0,0 +1,56 @@ +-- | +module Music.Theory.Unicode where + +type Unicode_Table = [(Int,String)] + +-- > putStrLn (map (toEnum . fst) (concat unicode)) +unicode :: [Unicode_Table] +unicode = [accidentals,notes,rests,clefs] + +accidentals :: Unicode_Table +accidentals = + [(0x1D12A,"MUSICAL SYMBOL DOUBLE SHARP") + ,(0x1D12B,"MUSICAL SYMBOL DOUBLE FLAT") + ,(0x1D12C,"MUSICAL SYMBOL FLAT UP") + ,(0x1D12D,"MUSICAL SYMBOL FLAT DOWN") + ,(0x1D12E,"MUSICAL SYMBOL NATURAL UP") + ,(0x1D12F,"MUSICAL SYMBOL NATURAL DOWN") + ,(0x1D130,"MUSICAL SYMBOL SHARP UP") + ,(0x1D131,"MUSICAL SYMBOL SHARP DOWN") + ,(0x1D132,"MUSICAL SYMBOL QUARTER TONE SHARP") + ,(0x1D133,"MUSICAL SYMBOL QUARTER TONE FLAT")] + +notes :: Unicode_Table +notes = + [(0x1D15C,"MUSICAL SYMBOL BREVE") + ,(0x1D15D,"MUSICAL SYMBOL WHOLE NOTE") + ,(0x1D15E,"MUSICAL SYMBOL HALF NOTE") + ,(0x1D15F,"MUSICAL SYMBOL QUARTER NOTE") + ,(0x1D160,"MUSICAL SYMBOL EIGHTH NOTE") + ,(0x1D161,"MUSICAL SYMBOL SIXTEENTH NOTE") + ,(0x1D162,"MUSICAL SYMBOL THIRTY-SECOND NOTE") + ,(0x1D163,"MUSICAL SYMBOL SIXTY-FOURTH NOTE") + ,(0x1D164,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE")] + +rests :: Unicode_Table +rests = + [(0x1D13B,"MUSICAL SYMBOL WHOLE REST") + ,(0x1D13C,"MUSICAL SYMBOL HALF REST") + ,(0x1D13D,"MUSICAL SYMBOL QUARTER REST") + ,(0x1D13E,"MUSICAL SYMBOL EIGHTH REST") + ,(0x1D13F,"MUSICAL SYMBOL SIXTEENTH REST") + ,(0x1D140,"MUSICAL SYMBOL THIRTY-SECOND REST") + ,(0x1D141,"MUSICAL SYMBOL SIXTY-FOURTH REST") + ,(0x1D142,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH REST")] + +clefs :: Unicode_Table +clefs = + [(0x1D11E,"MUSICAL SYMBOL G CLEF") + ,(0x1D11F,"MUSICAL SYMBOL G CLEF OTTAVA ALTA") + ,(0x1D120,"MUSICAL SYMBOL G CLEF OTTAVA BASSA") + ,(0x1D121,"MUSICAL SYMBOL C CLEF") + ,(0x1D122,"MUSICAL SYMBOL F CLEF") + ,(0x1D123,"MUSICAL SYMBOL F CLEF OTTAVA ALTA") + ,(0x1D124,"MUSICAL SYMBOL F CLEF OTTAVA BASSA") + ,(0x1D125,"MUSICAL SYMBOL DRUM CLEF-1") + ,(0x1D126,"MUSICAL SYMBOL DRUM CLEF-2")] 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 @@ -3,11 +3,12 @@ -- \"Towards a Philosophy of Music\", /Formalized Music/ pp. 219 -- 221 module Music.Theory.Xenakis.S4 where -import Data.List -import Data.Maybe -import qualified Data.Permute as P -import Music.Theory.Permutations +import Data.List {- base -} +import Data.Maybe {- base -} +import qualified Data.Permute as P {- permutation -} +import qualified Music.Theory.Permutations as T + -- * S4 notation -- | 'Label's for elements of the symmetric group P4. @@ -119,8 +120,8 @@ relate :: Half_Seq -> Half_Seq -> Rel relate p q = if complementary p q - then (True,permutation (complement p) q) - else (False,permutation p q) + then (True,T.permutation (complement p) q) + else (False,T.permutation p q) -- | 'Rel' from 'Label' /p/ to /q/. -- @@ -144,7 +145,7 @@ -- > apply_relation (False,P.listPermute 4 [0,3,1,2]) [1,4,2,3] == [1,3,4,2] apply_relation :: Rel -> Half_Seq -> Half_Seq apply_relation (c,p) i = - let j = apply_permutation p i + let j = T.apply_permutation p i in if c then complement j else j -- | Apply sequence of 'Rel' to initial 'Half_Seq'. 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 @@ -3,7 +3,7 @@ -- Vol. 28, No. 1 (Winter, 1990), pp. 58-78 module Music.Theory.Xenakis.Sieve where -import Data.List +import qualified Data.List as L import Music.Theory.List -- | Synonym for 'Integer' @@ -79,39 +79,52 @@ -- a sieve that contains an intersection clause that has no elements -- gives @_|_@. -- --- > let d = [0,2,4,5,7,9,11] --- > in take 7 (build (union (map (l 12) d))) == d +-- > let {d = [0,2,4,5,7,9,11] +-- > ;r = d ++ map (+ 12) d} +-- > in take 14 (build (union (map (l 12) d))) == r build :: Sieve -> [I] build s = - let u_f = map head . group + let u_f = map head . L.group i_f = let g [x,_] = [x] g _ = [] - in concatMap g . group + in concatMap g . L.group in case s of Empty -> [] L (m,i) -> [i, i+m ..] Union s0 s1 -> u_f (merge (build s0) (build s1)) Intersection s0 s1 -> i_f (merge (build s0) (build s1)) --- | Variant of 'build' that gives the first /n/ places of the --- 'reduce' of 'Sieve'. --- --- > buildn 6 (union (map (l 8) [0,3,6])) == [0,3,6,8,11,14] --- > buildn 12 (L (3,2)) == [2,5,8,11,14,17,20,23,26,29,32,35] --- > buildn 9 (L (8,0)) == [0,8,16,24,32,40,48,56,64] --- > buildn 3 (L (3,2) ∩ L (8,0)) == [8,32,56] --- > buildn 12 (L (3,1) ∪ L (4,0)) == [0,1,4,7,8,10,12,13,16,19,20,22] --- > buildn 14 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == [2,3,4,5,8,9,10,11,14,17,19,20,23,24] --- > buildn 6 (3⋄0 ∪ 4⋄0) == [0,3,4,6,8,9] --- > buildn 8 (5⋄2 ∩ 2⋄0 ∪ 7⋄3) == [2,3,10,12,17,22,24,31] --- > buildn 12 (5⋄1 ∪ 7⋄2) == [1,2,6,9,11,16,21,23,26,30,31,36] --- --- > buildn 10 (3⋄2 ∩ 4⋄7 ∪ 6⋄9 ∩ 15⋄18) == [3,11,23,33,35,47,59,63,71,83] --- --- > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19 --- > in buildn 16 s == buildn 16 (24⋄23 ∪ 30⋄3 ∪ 104⋄70) --- --- > buildn 10 (24⋄23 ∪ 30⋄3 ∪ 104⋄70) == [3,23,33,47,63,70,71,93,95,119] +{- | Variant of 'build' that gives the first /n/ places of the + 'reduce' of 'Sieve'. + +> buildn 6 (union (map (l 8) [0,3,6])) == [0,3,6,8,11,14] +> buildn 12 (L (3,2)) == [2,5,8,11,14,17,20,23,26,29,32,35] +> buildn 9 (L (8,0)) == [0,8,16,24,32,40,48,56,64] +> buildn 3 (L (3,2) ∩ L (8,0)) == [8,32,56] +> buildn 12 (L (3,1) ∪ L (4,0)) == [0,1,4,7,8,10,12,13,16,19,20,22] +> buildn 14 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == [2,3,4,5,8,9,10,11,14,17,19,20,23,24] +> buildn 6 (3⋄0 ∪ 4⋄0) == [0,3,4,6,8,9] +> buildn 8 (5⋄2 ∩ 2⋄0 ∪ 7⋄3) == [2,3,10,12,17,22,24,31] +> buildn 12 (5⋄1 ∪ 7⋄2) == [1,2,6,9,11,16,21,23,26,30,31,36] + +> buildn 10 (3⋄2 ∩ 4⋄7 ∪ 6⋄9 ∩ 15⋄18) == [3,11,23,33,35,47,59,63,71,83] + +> let {s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19 +> ;s' = 24⋄23 ∪ 30⋄3 ∪ 104⋄70} +> in buildn 16 s == buildn 16 s' + +> buildn 10 (24⋄23 ∪ 30⋄3 ∪ 104⋄70) == [3,23,33,47,63,70,71,93,95,119] + +> let r = [2,3,4,5,8,9,10,11,14,17,19,20,23,24,26,29,31] +> in buildn 17 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == r + +> let r = [0,1,3,6,9,10,11,12,15,16,17,18,21,24,26,27,30] +> in buildn 17 (5⋄1 ∪ 3⋄0 ∪ 7⋄3) == r + +> let r = [0,2,3,4,6,7,9,11,12,15,17,18,21,22,24,25,27,30,32] +> in buildn 19 (5⋄2 ∪ 3⋄0 ∪ 7⋄4) == r + +-} buildn :: Int -> Sieve -> [I] buildn n = take n . build . reduce diff --git a/Music/Theory/Z.hs b/Music/Theory/Z.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z.hs @@ -0,0 +1,94 @@ +-- | Generalised Z-/n/ functions. +module Music.Theory.Z where + +{- + +From GHC 7.6 onwards there is the modular-arithmetic package, which subsumes this work. + +{-# Language DataKinds #-} + +import Data.Modular {- modular-arithmetic -} +import GHC.TypeLits {- base -} + +type Z n = Mod Integer n + +-- > map negate [0::Z12 .. 11] == [0,11,10,9,8,7,6,5,4,3,2,1] +-- > map (+ 5) [0::Z12 .. 11] == [5,6,7,8,9,10,11,0,1,2,3,4] +type Z12 = Mod Integer 12 + +-- > map invert [0::Z12 .. 11] == [0,11,10,9,8,7,6,5,4,3,2,1] +invert :: KnownNat n => Z n -> Z n +invert = negate + +-} + +import Data.List {- base -} + +lift_unary_Z :: Integral a => a -> (t -> a) -> t -> a +lift_unary_Z z f n = mod (f n) z + +lift_binary_Z :: Integral a => a -> (s -> t -> a) -> s -> t -> a +lift_binary_Z z f n1 n2 = mod (n1 `f` n2) z + +-- > import Music.Theory.Z +-- > import qualified Music.Theory.Z12 as Z12 +-- > z_mod 12 (6::Z12.Z12) 12 +-- > z_add 12 (1::Z12.Z12) 5 +-- > (1::Z12.Z12) + 5 +-- > map (z_add 12 4) [1,5,6] == [5,9,10] +z_add :: Integral a => a -> a -> a -> a +z_add z = lift_binary_Z z (+) + +z_sub :: Integral a => a -> a -> a -> a +z_sub z = lift_binary_Z z (-) + +z_mul :: Integral a => a -> a -> a -> a +z_mul z = lift_binary_Z z (*) + +z_negate :: Integral a => a -> a -> a +z_negate z = lift_unary_Z z negate + +z_fromInteger :: Integral a => a -> Integer -> a +z_fromInteger z i = fromInteger i `mod` z + +z_signum :: t -> t1 -> t2 +z_signum _ _ = error "Z numbers are not signed" + +z_abs :: t -> t1 -> t2 +z_abs _ _ = error "Z numbers are not signed" + +-- > map (to_Z 12) [-9,-3,0] == [3,9,0] +to_Z :: Integral i => i -> i -> i +to_Z z = z_fromInteger z . fromIntegral + +from_Z :: (Integral i,Num n) => i -> n +from_Z = fromIntegral + +-- | Z not in set. +-- +-- > z_complement 5 [0,2,3] == [1,4] +-- > z_complement 12 [0,2,4,5,7,9,11] == [1,3,6,8,10] +z_complement :: (Enum a, Eq a, Num a) => a -> [a] -> [a] +z_complement z = (\\) [0 .. z - 1] + +z_quot :: Integral i => i -> i -> i -> i +z_quot z p = to_Z z . quot p + +z_rem :: Integral c => c -> c -> c -> c +z_rem z p = to_Z z . rem p + +z_div :: Integral c => c -> c -> c -> c +z_div z p = to_Z z . div p + +-- > z_mod 12 6 12 +z_mod :: Integral c => c -> c -> c -> c +z_mod z p = to_Z z . mod p + +z_quotRem :: Integral t => t -> t -> t -> (t, t) +z_quotRem z p q = (z_quot z p q,z_quot z p q) + +z_divMod :: Integral t => t -> t -> t -> (t, t) +z_divMod z p q = (z_div z p q,z_mod z p q) + +z_toInteger :: Integral i => i -> i -> i +z_toInteger z = to_Z z diff --git a/Music/Theory/Z/Forte_1973.hs b/Music/Theory/Z/Forte_1973.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Forte_1973.hs @@ -0,0 +1,101 @@ +-- | Allen Forte. /The Structure of Atonal Music/. Yale University +-- Press, New Haven, 1973. +module Music.Theory.Z.Forte_1973 where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import Music.Theory.List +import qualified Music.Theory.Set.List as S +import Music.Theory.Z +import Music.Theory.Z.SRO + +-- * Prime form + +-- | T-related rotations of /p/. +-- +-- > t_rotations 12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]] +t_rotations :: Integral a => a -> [a] -> [[a]] +t_rotations z p = + let r = rotations (sort p) + in map (tn_to z 0) r + +-- | T\/I-related rotations of /p/. +-- +-- > ti_rotations 12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10] +-- > ,[0,9,11],[0,2,3],[0,1,10]] +ti_rotations :: Integral a => a -> [a] -> [[a]] +ti_rotations z p = + let q = invert z 0 p + r = rotations (sort p) ++ rotations (sort q) + in map (tn_to z 0) r + +-- | Variant with default value for empty input list case. +minimumBy_or :: a -> (a -> a -> Ordering) -> [a] -> a +minimumBy_or p f q = if null q then p else minimumBy f q + +-- | Prime form rule requiring comparator, considering 't_rotations'. +t_cmp_prime :: Integral a => a -> ([a] -> [a] -> Ordering) -> [a] -> [a] +t_cmp_prime z f = minimumBy_or [] f . t_rotations z + +-- | Prime form rule requiring comparator, considering 'ti_rotations'. +ti_cmp_prime :: Integral a => a -> ([a] -> [a] -> Ordering) -> [a] -> [a] +ti_cmp_prime z f = minimumBy_or [] f . ti_rotations z + +-- | Forte comparison function (rightmost first then leftmost outwards). +-- +-- > forte_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == LT +forte_cmp :: (Ord t) => [t] -> [t] -> Ordering +forte_cmp [] [] = EQ +forte_cmp p q = + let r = compare (last p) (last q) + in if r == EQ then compare p q else r + +-- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'. +-- +-- > forte_prime 12 [0,1,3,6,8,9] == [0,1,3,6,8,9] +-- > forte_prime 5 [0,1,4] == [0,1,2] +-- +-- > S.set (map (forte_prime 5) (S.powerset [0..4])) +forte_prime :: Integral a => a -> [a] -> [a] +forte_prime z = ti_cmp_prime z forte_cmp + +-- | Transpositional equivalence prime form, ie. 't_cmp_prime' of +-- 'forte_cmp'. +-- +-- > (forte_prime 12 [0,2,3],t_prime 12 [0,2,3]) == ([0,1,3],[0,2,3]) +t_prime :: Integral a => a -> [a] -> [a] +t_prime z = t_cmp_prime z forte_cmp + +-- * ICV Metric + +-- | Interval class of i interval /i/. +-- +-- > map (ic 5) [1,2,3,4] == [1,2,2,1] +-- > map (ic 12) [5,6,7] == [5,6,5] +-- > map (ic 12 . to_Z 12) [-13,-1,0,1,13] == [1,1,0,1,1] +ic :: Integral a => a -> a -> a +ic z i = if i <= (z `div` 2) then i else z_sub z z i + +-- | Forte notation for interval class vector. +-- +-- > icv 12 [0,1,2,4,7,8] == [3,2,2,3,3,2] +icv :: (Integral i, Num n) => i -> [i] -> [n] +icv z s = + let i = map (ic z . uncurry (z_sub z)) (S.pairs s) + j = map f (group (sort i)) + k = map (`lookup` j) [1 .. z `div` 2] + f l = (head l,genericLength l) + in map (fromMaybe 0) k + +-- * BIP Metric + +-- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\" +-- /JMT/ 17/2 (1973):234-272 +-- +-- >>> bip 0t95728e3416 +-- 11223344556 +-- +-- > bip 12 [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6] +bip :: Integral a => a -> [a] -> [a] +bip z = sort . map (ic z . to_Z z) . d_dx diff --git a/Music/Theory/Z/Read_1978.hs b/Music/Theory/Z/Read_1978.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Read_1978.hs @@ -0,0 +1,144 @@ +-- | Ronald C. Read. \"Every one a winner or how to avoid isomorphism +-- search when cataloguing combinatorial configurations.\" /Annals of +-- Discrete Mathematics/ 2:107–20, 1978. +module Music.Theory.Z.Read_1978 where + +import Data.Bits {- base -} +import Data.Char {- base -} +import Data.Function {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Z.SRO as T {- hmt -} + +-- | Coding. +type Code = Int + +-- | Bit array. +type Array = [Bool] + +-- | Pretty printer for 'Array'. +array_pp :: Array -> String +array_pp = map intToDigit . map fromEnum + +-- | Parse PP of 'Array'. +-- +-- > parse_array "01001" == [False,True,False,False,True] +parse_array :: String -> Array +parse_array = map (toEnum . digitToInt) + +-- | Generate 'Code' from 'Array', the coding is most to least significant. +-- +-- > array_to_code (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == 6428 +array_to_code :: Array -> Code +array_to_code a = + let n = length a + f e j = if e then 2 ^ (n - j - 1) else 0 + in sum (zipWith f a [0..]) + +-- | Inverse of 'array_to_code'. +-- +-- > code_to_array 13 6428 == map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0] +code_to_array :: Int -> Code -> Array +code_to_array n c = map (testBit c) [n - 1, n - 2 .. 0] + +-- | Array to set. +-- +-- > array_to_set (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == [0,1,4,8,9,10] +-- > T.encode [0,1,4,8,9,10] == 1811 +array_to_set :: Integral i => [Bool] -> [i] +array_to_set = + let f (i,e) = if e then Just i else Nothing + in mapMaybe f . zip [0..] + +-- | Inverse of 'array_to_set', /z/ is the degree of the array. +set_to_array :: Integral i => i -> [i] -> Array +set_to_array z p = map (`elem` p) [0 .. z - 1] + +-- | 'array_to_code' of 'set_to_array'. +-- +-- > set_to_code 12 [0,2,3,5] +-- > map (set_to_code 12) (T.ti_related 12 [0,2,3,5]) +set_to_code :: Integral i => i -> [i] -> Code +set_to_code z = array_to_code . set_to_array z + +-- | Logical complement. +array_complement :: Array -> Array +array_complement = map not + +-- | The /prime/ form is the 'maximum' encoding. +-- +-- > array_is_prime (set_to_array 12 [0,2,3,5]) == False +array_is_prime :: Array -> Bool +array_is_prime a = + let c = array_to_code a + p = array_to_set a + z = length a + u = maximum (map (set_to_code z) (T.ti_related z p)) + in c == u + +-- | The augmentation rule adds @1@ in each empty slot at end of array. +-- +-- > map array_pp (array_augment (parse_array "01000")) == ["01100","01010","01001"] +array_augment :: Array -> [Array] +array_augment a = + let (z,a') = break id (reverse a) + a'' = reverse a' + n = length z + f k = map (== k) [0 .. n - 1] + x = map f [0 .. n - 1] + in map (a'' ++) x + +-- | Enumerate first half of the set-classes under given /prime/ function. +-- The second half can be derived as the complement of the first. +-- +-- > import Music.Theory.Z12.Forte_1973 +-- > length scs == 224 +-- > map (length . scs_n) [0..12] == [1,1,6,12,29,38,50,38,29,12,6,1,1] +-- +-- > let z12 = map (fmap (map array_to_set)) (enumerate_half array_is_prime 12) +-- > map (length . snd) z12 == [1,1,6,12,29,38,50] +-- +-- This can become slow, edit /z/ to find out. It doesn't matter +-- about /n/. This can be edited so that small /n/ would run quickly +-- even for large /z/. +-- +-- > fmap (map array_to_set) (lookup 5 (enumerate_half array_is_prime 16)) +enumerate_half :: (Array -> Bool) -> Int -> [(Int,[Array])] +enumerate_half pr n = + let a0 = replicate n False + f k a = if k >= n `div` 2 + then [] + else let r = filter pr (array_augment a) + in (k + 1,r) : concatMap (f (k + 1)) r + jn l = case l of + (x,y):l' -> (x,concat (y : map snd l')) + _ -> error "" + post_proc = map jn . groupBy ((==) `on` fst) . sortBy (compare `on` fst) + in post_proc ((0,[a0]) : f 0 a0) + +-- * Alternate (reverse) form. + +-- | Encoder for 'encode_prime'. +-- +-- > encode [0,1,3,6,8,9] == 843 +encode :: Integral i => [i] -> Code +encode = sum . map (2 ^) + +-- | Decoder for 'encode_prime'. +-- +-- > decode 12 843 == [0,1,3,6,8,9] +decode :: Integral i => i -> Code -> [i] +decode z n = + let f i = (i,testBit n (fromIntegral i)) + in map fst (filter snd (map f [0 .. z - 1])) + +-- | Binary encoding prime form algorithm, equalivalent to Rahn. +-- +-- > encode_prime 12 [0,1,3,6,8,9] == [0,2,3,6,7,9] +-- > Music.Theory.Z12.Rahn_1980.rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] +encode_prime :: Integral i => i -> [i] -> [i] +encode_prime z s = + let t = map (\n -> T.tn z n s) [0..11] + c = t ++ map (T.invert z 0) t + in decode z (minimum (map encode c)) diff --git a/Music/Theory/Z/SRO.hs b/Music/Theory/Z/SRO.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/SRO.hs @@ -0,0 +1,83 @@ +-- | Serial (ordered) pitch-class operations on 'Z'. +module Music.Theory.Z.SRO where + +import Data.List {- base -} + +import Music.Theory.Z + +-- | Transpose /p/ by /n/. +-- +-- > tn 5 4 [0,1,4] == [4,0,3] +-- > tn 12 4 [1,5,6] == [5,9,10] +tn :: (Integral i, Functor f) => i -> i -> f i -> f i +tn z n = fmap (z_add z n) + +-- | Invert /p/ about /n/. +-- +-- > invert 5 0 [0,1,4] == [0,4,1] +-- > invert 12 6 [4,5,6] == [8,7,6] +-- > invert 12 0 [0,1,3] == [0,11,9] +invert :: (Integral i, Functor f) => i -> i -> f i -> f i +invert z n = fmap (\p -> z_sub z n (z_sub z p n)) + +-- | Composition of 'invert' about @0@ and 'tn'. +-- +-- > tni 5 1 [0,1,3] == [1,0,3] +-- > tni 12 4 [1,5,6] == [3,11,10] +-- > (invert 12 0 . tn 12 4) [1,5,6] == [7,3,2] +tni :: (Integral i, Functor f) => i -> i -> f i -> f i +tni z n = tn z n . invert z 0 + +-- | Modulo multiplication. +-- +-- > mn 12 11 [0,1,4,9] == tni 12 0 [0,1,4,9] +mn :: (Integral i, Functor f) => i -> i -> f i -> f i +mn z n = fmap (z_mul z n) + +-- | T-related sequences of /p/. +-- +-- > length (t_related 12 [0,3,6,9]) == 12 +t_related :: (Integral i, Functor f) => i -> f i -> [f i] +t_related z p = fmap (\n -> tn z n p) [0..11] + +-- | T\/I-related sequences of /p/. +-- +-- > length (ti_related 12 [0,1,3]) == 24 +-- > length (ti_related 12 [0,3,6,9]) == 24 +-- > ti_related 12 [0] == map return [0..11] +ti_related :: (Eq (f i), Integral i, Functor f) => i -> f i -> [f i] +ti_related z p = nub (t_related z p ++ t_related z (invert z 0 p)) + +-- | R\/T\/I-related sequences of /p/. +-- +-- > length (rti_related 12 [0,1,3]) == 48 +-- > length (rti_related 12 [0,3,6,9]) == 24 +rti_related :: Integral i => i -> [i] -> [[i]] +rti_related z p = let q = ti_related z p in nub (q ++ map reverse q) + +-- * Sequence operations + +-- | Variant of 'tn', transpose /p/ so first element is /n/. +-- +-- > tn_to 12 5 [0,1,3] == [5,6,8] +-- > map (tn_to 12 0) [[0,1,3],[1,3,0],[3,0,1]] +tn_to :: Integral a => a -> a -> [a] -> [a] +tn_to z n p = + case p of + [] -> [] + x:xs -> n : tn z (z_sub z n x) xs + +-- | Variant of 'invert', inverse about /n/th element. +-- +-- > map (invert_ix 12 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] +-- > map (invert_ix 12 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] +invert_ix :: Integral i => i -> Int -> [i] -> [i] +invert_ix z n p = invert z (p !! n) p + +-- | The standard t-matrix of /p/. +-- +-- > tmatrix 12 [0,1,3] == [[0,1,3] +-- > ,[11,0,2] +-- > ,[9,10,0]] +tmatrix :: Integral i => i -> [i] -> [[i]] +tmatrix z p = map (\n -> tn z n p) (tn_to z 0 (invert_ix z 0 p)) diff --git a/Music/Theory/Z12.hs b/Music/Theory/Z12.hs --- a/Music/Theory/Z12.hs +++ b/Music/Theory/Z12.hs @@ -1,35 +1,102 @@ {-# Language GeneralizedNewtypeDeriving #-} module Music.Theory.Z12 where -import Data.List +import Data.List {- base -} -newtype Z12 = Z12 Int deriving (Eq,Ord,Enum,Bounded,Integral,Real) -instance Show Z12 where showsPrec p (Z12 i) = showsPrec p i +-- | 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) -liftUZ12 :: (Int -> Int) -> Z12 -> Z12 -liftUZ12 f (Z12 a) = Z12 (mod (f a) 12) +-- | 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 -liftBZ12 :: (Int -> Int -> Int) -> Z12 -> Z12 -> Z12 -liftBZ12 f (Z12 a) (Z12 b) = Z12 (mod (a `f` b) 12) +-- | 'Bounded' instance for Z12. +-- +-- > [minBound::Z12 .. maxBound] == [0::Z12 .. 11] +instance Bounded Z12 where + minBound = Z12 0 + maxBound = Z12 11 +-- | The Z12 modulo (ie. @12@) as a 'Z12' value. This is required +-- when lifting generalised @Z@ functions to 'Z12'. It is /not/ the +-- same as writing @12::Z12@. +-- +-- > z12_modulo == Z12 12 +-- > z12_modulo /= 12 +-- > (12::Z12) == 0 +-- > show z12_modulo == "(Z12 12)" +z12_modulo :: Z12 +z12_modulo = Z12 12 + +-- | Basis for Z12 show instance. +-- +-- > map show [-1,0::Z12,1,z12_modulo] == ["11","0","1","(Z12 12)"] +z12_showsPrec :: Int -> Z12 -> ShowS +z12_showsPrec p (Z12 i) = + let x = showsPrec p i + in if i < 0 || i > 11 + then showString "(Z12 " . x . showString ")" + else x + +instance Show Z12 where showsPrec = z12_showsPrec + +-- | Lift unary function over integers to Z12. +-- +-- > lift_unary_Z12 (negate) 7 == 5 +lift_unary_Z12 :: (Int -> Int) -> Z12 -> Z12 +lift_unary_Z12 f (Z12 a) = Z12 (f a `mod` 12) + +-- | Lift unary function over integers to Z12. +-- +-- > map (lift_binary_Z12 (+) 4) [1,5,6] == [5,9,10] +lift_binary_Z12 :: (Int -> Int -> Int) -> Z12 -> Z12 -> Z12 +lift_binary_Z12 f (Z12 a) (Z12 b) = Z12 (mod (a `f` b) 12) + +-- | Raise an error if the internal 'Z12' value is negative. +check_negative :: (Int -> Int) -> Z12 -> Z12 +check_negative f (Z12 n) = + if n < 0 + then error "check_negative: negative Z12" + else Z12 (f n) + instance Num Z12 where - (+) = liftBZ12 (+) - (-) = liftBZ12 (-) - (*) = liftBZ12 (*) - negate = liftUZ12 negate - fromInteger i = Z12 (fromInteger i `mod` 12) - signum _ = error "Z12 numbers are not signed" - abs _ = error "Z12 numbers are not signed" + (+) = 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 --- > map toZ12 [-9,-3,0] == [3,9,0] -toZ12 :: Integral i => i -> Z12 -toZ12 = fromIntegral +-- | Convert integral to 'Z12'. +-- +-- > map to_Z12 [-9,-3,0,13] == [3,9,0,1] +to_Z12 :: Integral i => i -> Z12 +to_Z12 = fromIntegral -fromZ12 :: Integral i => Z12 -> i -fromZ12 = fromIntegral +-- | Convert 'Z12' to integral. +from_Z12 :: Integral i => Z12 -> i +from_Z12 = fromIntegral -- | Z12 not in set. -- -- > complement [0,2,4,5,7,9,11] == [1,3,6,8,10] complement :: [Z12] -> [Z12] -complement = (\\) [0..11] +complement = (\\) [0 .. 11] 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 @@ -2,27 +2,22 @@ -- thesis, Sibelius Academy, Helsinki, 1994. module Music.Theory.Z12.Castren_1994 where -import Data.List -import Data.Maybe -import Data.Ratio -import Music.Theory.List -import Music.Theory.Z12 -import Music.Theory.Z12.Forte_1973 -import Music.Theory.Z12.TTO +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} --- | 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 = t_cmp_prime forte_cmp +import qualified Music.Theory.List as T +import Music.Theory.Z12 (Z12) +import qualified Music.Theory.Z12.Forte_1973 as T +import qualified Music.Theory.Z12.TTO as T -- | Is /p/ symmetrical under inversion. -- +-- > import Music.Theory.Z12.Forte_1973 -- > map inv_sym (scs_n 2) == [True,True,True,True,True,True] -- > map (fromEnum.inv_sym) (scs_n 3) == [1,0,0,0,0,1,0,0,1,1,0,1] inv_sym :: [Z12] -> Bool -inv_sym x = x `elem` map (\i -> sort (tn i (invert 0 x))) [0..11] +inv_sym x = x `elem` map (\i -> sort (T.tn i (T.invert 0 x))) [0..11] -- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'. -- @@ -32,7 +27,7 @@ sc_t_ti p = if inv_sym p then Nothing - else Just (p,t_prime (invert 0 p)) + else Just (p,T.t_prime (T.invert 0 p)) -- | Transpositional equivalence variant of Forte's 'sc_table'. The -- inversionally related classes are distinguished by labels @A@ and @@ -42,28 +37,28 @@ -- -- > (length sc_table,length t_sc_table) == (224,352) -- > lookup "5-Z18B" t_sc_table == Just [0,2,3,6,7] -t_sc_table :: [(SC_Name,[Z12])] +t_sc_table :: [(T.SC_Name,[Z12])] t_sc_table = - let f x = let nm = sc_name x + let f x = let nm = T.sc_name x in case sc_t_ti x of Nothing -> [(nm,x)] Just (p,q) -> [(nm++"A",p),(nm++"B",q)] - in concatMap f scs + in concatMap f T.scs -- | Lookup a set-class name. The input set is subject to -- 't_prime' before lookup. -- -- > t_sc_name [0,2,3,6,7] == "5-Z18B" -- > t_sc_name [0,1,4,6,7,8] == "6-Z17B" -t_sc_name :: [Z12] -> SC_Name +t_sc_name :: [Z12] -> T.SC_Name t_sc_name p = - let n = find (\(_,q) -> t_prime p == q) t_sc_table + let n = find (\(_,q) -> T.t_prime p == q) t_sc_table in fst (fromJust n) -- | Lookup a set-class given a set-class name. -- -- > t_sc "6-Z17A" == [0,1,2,4,7,8] -t_sc :: SC_Name -> [Z12] +t_sc :: T.SC_Name -> [Z12] t_sc n = snd (fromJust (find (\(m,_) -> n == m) t_sc_table)) -- | List of set classes. @@ -82,7 +77,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 (`is_subset` x) (t_related a) +t_subsets x a = filter (`T.is_subset` x) (T.t_related a) -- | T\/I-related /q/ that are subsets of /p/. -- @@ -90,7 +85,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 (`is_subset` x) (ti_related a) +ti_subsets x a = filter (`T.is_subset` x) (T.ti_related a) -- | Trivial run length encoder. -- @@ -131,7 +126,7 @@ -- > rle (ti_n_class_vector 4 [0,1,2,3,4]) == [(2,2),(1,1),(26,0)] ti_n_class_vector :: (Num b, Integral i) => i -> [Z12] -> [b] ti_n_class_vector n x = - let a = scs_n n + let a = T.scs_n n in map (genericLength . ti_subsets x) a -- | 'icv' scaled by sum of /icv/. @@ -140,7 +135,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' = icv p + let p' = T.icv 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 @@ -2,16 +2,17 @@ -- See . module Music.Theory.Z12.Drape_1999 where -import Data.Function -import Data.List -import Data.Maybe -import Music.Theory.List -import qualified Music.Theory.Set.List as S +import Data.Function {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.List as T +import qualified Music.Theory.Set.List as T import Music.Theory.Z12 -import Music.Theory.Z12.Forte_1973 -import Music.Theory.Z12.Morris_1987 -import qualified Music.Theory.Z12.TTO as T -import qualified Music.Theory.Z12.SRO as S +import qualified Music.Theory.Z12.Forte_1973 as T +import qualified Music.Theory.Z12.Morris_1987 as T +import qualified Music.Theory.Z12.TTO as TTO +import qualified Music.Theory.Z12.SRO as SRO -- | Cardinality filter -- @@ -29,11 +30,11 @@ x:xs -> [ y:z | y <- x, z <- cgg xs ] _ -> [[]] --- | Combinations generator, ie. synonym for 'S.powerset'. +-- | Combinations generator, ie. synonym for 'T.powerset'. -- -- > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]] cg :: [a] -> [[a]] -cg = S.powerset +cg = T.powerset -- | Powerset filtered by cardinality. -- @@ -49,7 +50,7 @@ -- | Cyclic interval segment. ciseg :: [Z12] -> [Z12] -ciseg = int . cyc +ciseg = T.int . cyc -- | Synonynm for 'complement'. -- @@ -67,8 +68,10 @@ -- -- > cyc [0,5,6] == [0,5,6,0] cyc :: [a] -> [a] -cyc [] = [] -cyc (x:xs) = (x:xs) ++ [x] +cyc l = + case l of + [] -> [] + x:xs -> (x:xs) ++ [x] -- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor -- set, 'o' for octotonic set. @@ -83,7 +86,7 @@ -- | Diatonic implications. dim :: [Z12] -> [(Z12,[Z12])] dim p = - let g (i,q) = is_subset p (T.tn i q) + let g (i,q) = T.is_subset p (TTO.tn i q) f = filter g . zip [0..11] . repeat d = [0,2,4,5,7,9,11] m = [0,2,3,5,7,9,11] @@ -128,16 +131,16 @@ -- >>> echo 01234 | doi 2 7-35 | sort -u -- 13568AB -- --- > doi 2 (sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]] +-- > doi 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 = [T.tn j p,T.tni j p] + let f j = [TTO.tn j p,TTO.tni j p] xs = concatMap f [0..11] - in S.set (filter (\x -> length (x `intersect` q) == n) xs) + in T.set (filter (\x -> length (x `intersect` q) == n) xs) -- | Forte name. fn :: [Z12] -> String -fn = sc_name +fn = T.sc_name -- | p `has_ess` q is true iff p can embed q in sequence. has_ess :: [Z12] -> [Z12] -> Bool @@ -155,7 +158,7 @@ -- -- > ess [2,3,10] [0,1,6,4,3,2,5] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]] ess :: [Z12] -> [Z12] -> [[Z12]] -ess p = filter (`has_ess` p) . S.rtmi_related +ess p = filter (`has_ess` p) . SRO.rtmi_related -- | Can the set-class q (under prime form algorithm pf) be -- drawn from the pcset p. @@ -166,7 +169,7 @@ -- | Can the set-class q be drawn from the pcset p. has_sc :: [Z12] -> [Z12] -> Bool -has_sc = has_sc_pf forte_prime +has_sc = has_sc_pf T.forte_prime -- | Interval cycle filter. -- @@ -206,11 +209,11 @@ -- -- > 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 ic . iseg +icseg = map T.ic . iseg -- | Interval segment (INT). iseg :: [Z12] -> [Z12] -iseg = int +iseg = T.int -- | Imbrications. imb :: (Integral n) => [n] -> [a] -> [[a]] @@ -226,12 +229,12 @@ -- 3-2 -- 3-11 -- --- > issb (sc "3-7") (sc "6-32") == ["3-2","3-7","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 -> forte_prime (p ++ x) == q) . T.ti_related - in map sc_name (filter f (cf [k] scs)) + f = any id . map (\x -> T.forte_prime (p ++ x) == q) . TTO.ti_related + in map T.sc_name (filter f (cf [k] T.scs)) -- | Matrix search. -- @@ -239,9 +242,9 @@ -- 6421B9 -- B97642 -- --- > S.set (mxs [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]] +-- > 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`) (S.rti_related p) +mxs p q = filter (q `isInfixOf`) (SRO.rti_related p) -- | Normalize. -- @@ -250,7 +253,7 @@ -- -- > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6] nrm :: (Ord a) => [a] -> [a] -nrm = S.set +nrm = T.set -- | Normalize, retain duplicate elements. nrm_r :: (Ord a) => [a] -> [a] @@ -267,8 +270,8 @@ -- > 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 = S.set (map (q `genericIndex`) i) - in filter (\q -> f q == f p) (S.rti_related p) + let f q = T.set (map (q `genericIndex`) i) + in filter (\q -> f q == f p) (SRO.rti_related p) -- | Relate sets. -- @@ -278,11 +281,11 @@ -- > 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] -> [(SRO, [Z12])] +rs :: [Z12] -> [Z12] -> [(T.SRO, [Z12])] rs x y = - let xs = map (\o -> (o, o `sro` x)) sro_TnMI - q = S.set y - in filter (\(_,p) -> S.set p == q) xs + let xs = map (\o -> (o, o `T.sro` x)) T.sro_TnMI + q = T.set y + in filter (\(_,p) -> T.set p == q) xs -- | Relate segments. -- @@ -306,34 +309,34 @@ -- -- > rsg [0,1,2,3] [11,6,1,4] == [rnrtnmi "r1T4MI",rnrtnmi "r1RT1M"] -- -rsg :: [Z12] -> [Z12] -> [SRO] -rsg x y = map fst (filter (\(_,x') -> x' == y) (sros x)) +rsg :: [Z12] -> [Z12] -> [T.SRO] +rsg x y = map fst (filter (\(_,x') -> x' == y) (T.sros x)) -- | Subsets. sb :: [[Z12]] -> [[Z12]] sb xs = let f p = all id (map (`has_sc` p) xs) - in filter f scs + in filter f T.scs -- | Super set-class. -- -- >>> spsc 4-11 4-12 -- 5-26[02458] -- --- > spsc [sc "4-11", sc "4-12"] == ["5-26"] +-- > spsc [T.sc "4-11",T.sc "4-12"] == ["5-26"] -- -- >>> spsc 3-11 3-8 -- 4-27[0258] -- 4-Z29[0137] -- --- > spsc [sc "3-11", sc "3-8"] == ["4-27","4-Z29"] +-- > spsc [T.sc "3-11",T.sc "3-8"] == ["4-27","4-Z29"] -- -- >>> spsc `fl 3` -- 6-Z17[012478] -- --- > spsc (cf [3] scs) == ["6-Z17"] +-- > spsc (cf [3] T.scs) == ["6-Z17"] spsc :: [[Z12]] -> [String] spsc xs = let f y = all (y `has_sc`) xs g = (==) `on` length - in (map sc_name . head . groupBy g . filter f) scs + in (map T.sc_name . head . groupBy g . filter f) T.scs 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,12 +2,11 @@ -- Press, New Haven, 1973. module Music.Theory.Z12.Forte_1973 where -import Data.List -import Data.Maybe -import Music.Theory.List -import qualified Music.Theory.Set.List as S +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Z.Forte_1973 as Z import Music.Theory.Z12 -import Music.Theory.Z12.SRO -- * Prime form @@ -15,53 +14,36 @@ -- -- > t_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]] t_rotations :: [Z12] -> [[Z12]] -t_rotations p = - let r = rotations (sort p) - in map (tn_to 0) r +t_rotations = Z.t_rotations z12_modulo -- | T\/I-related rotations of /p/. -- -- > ti_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10] -- > ,[0,9,11],[0,2,3],[0,1,10]] ti_rotations :: [Z12] -> [[Z12]] -ti_rotations p = - let q = invert 0 p - r = rotations (sort p) ++ rotations (sort q) - in map (tn_to 0) r - --- | Variant with default value for empty input list case. -minimumBy_or :: a -> (a -> a -> Ordering) -> [a] -> a -minimumBy_or p f q = if null q then p else minimumBy f q - --- | Prime form rule requiring comparator, considering 't_rotations'. -t_cmp_prime :: ([Z12] -> [Z12] -> Ordering) -> [Z12] -> [Z12] -t_cmp_prime f = minimumBy_or [] f . t_rotations - --- | Prime form rule requiring comparator, considering 'ti_rotations'. -ti_cmp_prime :: ([Z12] -> [Z12] -> Ordering) -> [Z12] -> [Z12] -ti_cmp_prime f = minimumBy_or [] f . ti_rotations - --- | 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 +ti_rotations = Z.ti_rotations z12_modulo -- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'. -- -- > forte_prime [0,1,3,6,8,9] == [0,1,3,6,8,9] forte_prime :: [Z12] -> [Z12] -forte_prime = ti_cmp_prime forte_cmp +forte_prime = Z.forte_prime z12_modulo +-- | Transpositional equivalence prime form, ie. 't_cmp_prime' of +-- 'forte_cmp'. +-- +-- > (forte_prime [0,2,3],t_prime [0,2,3]) == ([0,1,3],[0,2,3]) +t_prime :: [Z12] -> [Z12] +t_prime = Z.t_prime z12_modulo + -- * Set Class Table -- | Synonym for 'String'. type SC_Name = String -- | The set-class table (Forte prime forms). +-- +-- > length sc_table == 224 sc_table :: [(SC_Name,[Z12])] sc_table = [("0-1",[]) @@ -305,13 +287,241 @@ sc :: SC_Name -> [Z12] sc n = snd (fromMaybe (error "sc") (find (\(m,_) -> n == m) sc_table)) --- | List of set classes. +{- | List of set classes (the set class universe). + +> let r = [("0-1",[0,0,0,0,0,0]) +> ,("1-1",[0,0,0,0,0,0]) +> ,("2-1",[1,0,0,0,0,0]) +> ,("2-2",[0,1,0,0,0,0]) +> ,("2-3",[0,0,1,0,0,0]) +> ,("2-4",[0,0,0,1,0,0]) +> ,("2-5",[0,0,0,0,1,0]) +> ,("2-6",[0,0,0,0,0,1]) +> ,("3-1",[2,1,0,0,0,0]) +> ,("3-2",[1,1,1,0,0,0]) +> ,("3-3",[1,0,1,1,0,0]) +> ,("3-4",[1,0,0,1,1,0]) +> ,("3-5",[1,0,0,0,1,1]) +> ,("3-6",[0,2,0,1,0,0]) +> ,("3-7",[0,1,1,0,1,0]) +> ,("3-8",[0,1,0,1,0,1]) +> ,("3-9",[0,1,0,0,2,0]) +> ,("3-10",[0,0,2,0,0,1]) +> ,("3-11",[0,0,1,1,1,0]) +> ,("3-12",[0,0,0,3,0,0]) +> ,("4-1",[3,2,1,0,0,0]) +> ,("4-2",[2,2,1,1,0,0]) +> ,("4-3",[2,1,2,1,0,0]) +> ,("4-4",[2,1,1,1,1,0]) +> ,("4-5",[2,1,0,1,1,1]) +> ,("4-6",[2,1,0,0,2,1]) +> ,("4-7",[2,0,1,2,1,0]) +> ,("4-8",[2,0,0,1,2,1]) +> ,("4-9",[2,0,0,0,2,2]) +> ,("4-10",[1,2,2,0,1,0]) +> ,("4-11",[1,2,1,1,1,0]) +> ,("4-12",[1,1,2,1,0,1]) +> ,("4-13",[1,1,2,0,1,1]) +> ,("4-14",[1,1,1,1,2,0]) +> ,("4-Z15",[1,1,1,1,1,1]) +> ,("4-16",[1,1,0,1,2,1]) +> ,("4-17",[1,0,2,2,1,0]) +> ,("4-18",[1,0,2,1,1,1]) +> ,("4-19",[1,0,1,3,1,0]) +> ,("4-20",[1,0,1,2,2,0]) +> ,("4-21",[0,3,0,2,0,1]) +> ,("4-22",[0,2,1,1,2,0]) +> ,("4-23",[0,2,1,0,3,0]) +> ,("4-24",[0,2,0,3,0,1]) +> ,("4-25",[0,2,0,2,0,2]) +> ,("4-26",[0,1,2,1,2,0]) +> ,("4-27",[0,1,2,1,1,1]) +> ,("4-28",[0,0,4,0,0,2]) +> ,("4-Z29",[1,1,1,1,1,1]) +> ,("5-1",[4,3,2,1,0,0]) +> ,("5-2",[3,3,2,1,1,0]) +> ,("5-3",[3,2,2,2,1,0]) +> ,("5-4",[3,2,2,1,1,1]) +> ,("5-5",[3,2,1,1,2,1]) +> ,("5-6",[3,1,1,2,2,1]) +> ,("5-7",[3,1,0,1,3,2]) +> ,("5-8",[2,3,2,2,0,1]) +> ,("5-9",[2,3,1,2,1,1]) +> ,("5-10",[2,2,3,1,1,1]) +> ,("5-11",[2,2,2,2,2,0]) +> ,("5-Z12",[2,2,2,1,2,1]) +> ,("5-13",[2,2,1,3,1,1]) +> ,("5-14",[2,2,1,1,3,1]) +> ,("5-15",[2,2,0,2,2,2]) +> ,("5-16",[2,1,3,2,1,1]) +> ,("5-Z17",[2,1,2,3,2,0]) +> ,("5-Z18",[2,1,2,2,2,1]) +> ,("5-19",[2,1,2,1,2,2]) +> ,("5-20",[2,1,1,2,3,1]) +> ,("5-21",[2,0,2,4,2,0]) +> ,("5-22",[2,0,2,3,2,1]) +> ,("5-23",[1,3,2,1,3,0]) +> ,("5-24",[1,3,1,2,2,1]) +> ,("5-25",[1,2,3,1,2,1]) +> ,("5-26",[1,2,2,3,1,1]) +> ,("5-27",[1,2,2,2,3,0]) +> ,("5-28",[1,2,2,2,1,2]) +> ,("5-29",[1,2,2,1,3,1]) +> ,("5-30",[1,2,1,3,2,1]) +> ,("5-31",[1,1,4,1,1,2]) +> ,("5-32",[1,1,3,2,2,1]) +> ,("5-33",[0,4,0,4,0,2]) +> ,("5-34",[0,3,2,2,2,1]) +> ,("5-35",[0,3,2,1,4,0]) +> ,("5-Z36",[2,2,2,1,2,1]) +> ,("5-Z37",[2,1,2,3,2,0]) +> ,("5-Z38",[2,1,2,2,2,1]) +> ,("6-1",[5,4,3,2,1,0]) +> ,("6-2",[4,4,3,2,1,1]) +> ,("6-Z3",[4,3,3,2,2,1]) +> ,("6-Z4",[4,3,2,3,2,1]) +> ,("6-5",[4,2,2,2,3,2]) +> ,("6-Z6",[4,2,1,2,4,2]) +> ,("6-7",[4,2,0,2,4,3]) +> ,("6-8",[3,4,3,2,3,0]) +> ,("6-9",[3,4,2,2,3,1]) +> ,("6-Z10",[3,3,3,3,2,1]) +> ,("6-Z11",[3,3,3,2,3,1]) +> ,("6-Z12",[3,3,2,2,3,2]) +> ,("6-Z13",[3,2,4,2,2,2]) +> ,("6-14",[3,2,3,4,3,0]) +> ,("6-15",[3,2,3,4,2,1]) +> ,("6-16",[3,2,2,4,3,1]) +> ,("6-Z17",[3,2,2,3,3,2]) +> ,("6-18",[3,2,2,2,4,2]) +> ,("6-Z19",[3,1,3,4,3,1]) +> ,("6-20",[3,0,3,6,3,0]) +> ,("6-21",[2,4,2,4,1,2]) +> ,("6-22",[2,4,1,4,2,2]) +> ,("6-Z23",[2,3,4,2,2,2]) +> ,("6-Z24",[2,3,3,3,3,1]) +> ,("6-Z25",[2,3,3,2,4,1]) +> ,("6-Z26",[2,3,2,3,4,1]) +> ,("6-27",[2,2,5,2,2,2]) +> ,("6-Z28",[2,2,4,3,2,2]) +> ,("6-Z29",[2,2,4,2,3,2]) +> ,("6-30",[2,2,4,2,2,3]) +> ,("6-31",[2,2,3,4,3,1]) +> ,("6-32",[1,4,3,2,5,0]) +> ,("6-33",[1,4,3,2,4,1]) +> ,("6-34",[1,4,2,4,2,2]) +> ,("6-35",[0,6,0,6,0,3]) +> ,("6-Z36",[4,3,3,2,2,1]) +> ,("6-Z37",[4,3,2,3,2,1]) +> ,("6-Z38",[4,2,1,2,4,2]) +> ,("6-Z39",[3,3,3,3,2,1]) +> ,("6-Z40",[3,3,3,2,3,1]) +> ,("6-Z41",[3,3,2,2,3,2]) +> ,("6-Z42",[3,2,4,2,2,2]) +> ,("6-Z43",[3,2,2,3,3,2]) +> ,("6-Z44",[3,1,3,4,3,1]) +> ,("6-Z45",[2,3,4,2,2,2]) +> ,("6-Z46",[2,3,3,3,3,1]) +> ,("6-Z47",[2,3,3,2,4,1]) +> ,("6-Z48",[2,3,2,3,4,1]) +> ,("6-Z49",[2,2,4,3,2,2]) +> ,("6-Z50",[2,2,4,2,3,2]) +> ,("7-1",[6,5,4,3,2,1]) +> ,("7-2",[5,5,4,3,3,1]) +> ,("7-3",[5,4,4,4,3,1]) +> ,("7-4",[5,4,4,3,3,2]) +> ,("7-5",[5,4,3,3,4,2]) +> ,("7-6",[5,3,3,4,4,2]) +> ,("7-7",[5,3,2,3,5,3]) +> ,("7-8",[4,5,4,4,2,2]) +> ,("7-9",[4,5,3,4,3,2]) +> ,("7-10",[4,4,5,3,3,2]) +> ,("7-11",[4,4,4,4,4,1]) +> ,("7-Z12",[4,4,4,3,4,2]) +> ,("7-13",[4,4,3,5,3,2]) +> ,("7-14",[4,4,3,3,5,2]) +> ,("7-15",[4,4,2,4,4,3]) +> ,("7-16",[4,3,5,4,3,2]) +> ,("7-Z17",[4,3,4,5,4,1]) +> ,("7-Z18",[4,3,4,4,4,2]) +> ,("7-19",[4,3,4,3,4,3]) +> ,("7-20",[4,3,3,4,5,2]) +> ,("7-21",[4,2,4,6,4,1]) +> ,("7-22",[4,2,4,5,4,2]) +> ,("7-23",[3,5,4,3,5,1]) +> ,("7-24",[3,5,3,4,4,2]) +> ,("7-25",[3,4,5,3,4,2]) +> ,("7-26",[3,4,4,5,3,2]) +> ,("7-27",[3,4,4,4,5,1]) +> ,("7-28",[3,4,4,4,3,3]) +> ,("7-29",[3,4,4,3,5,2]) +> ,("7-30",[3,4,3,5,4,2]) +> ,("7-31",[3,3,6,3,3,3]) +> ,("7-32",[3,3,5,4,4,2]) +> ,("7-33",[2,6,2,6,2,3]) +> ,("7-34",[2,5,4,4,4,2]) +> ,("7-35",[2,5,4,3,6,1]) +> ,("7-Z36",[4,4,4,3,4,2]) +> ,("7-Z37",[4,3,4,5,4,1]) +> ,("7-Z38",[4,3,4,4,4,2]) +> ,("8-1",[7,6,5,4,4,2]) +> ,("8-2",[6,6,5,5,4,2]) +> ,("8-3",[6,5,6,5,4,2]) +> ,("8-4",[6,5,5,5,5,2]) +> ,("8-5",[6,5,4,5,5,3]) +> ,("8-6",[6,5,4,4,6,3]) +> ,("8-7",[6,4,5,6,5,2]) +> ,("8-8",[6,4,4,5,6,3]) +> ,("8-9",[6,4,4,4,6,4]) +> ,("8-10",[5,6,6,4,5,2]) +> ,("8-11",[5,6,5,5,5,2]) +> ,("8-12",[5,5,6,5,4,3]) +> ,("8-13",[5,5,6,4,5,3]) +> ,("8-14",[5,5,5,5,6,2]) +> ,("8-Z15",[5,5,5,5,5,3]) +> ,("8-16",[5,5,4,5,6,3]) +> ,("8-17",[5,4,6,6,5,2]) +> ,("8-18",[5,4,6,5,5,3]) +> ,("8-19",[5,4,5,7,5,2]) +> ,("8-20",[5,4,5,6,6,2]) +> ,("8-21",[4,7,4,6,4,3]) +> ,("8-22",[4,6,5,5,6,2]) +> ,("8-23",[4,6,5,4,7,2]) +> ,("8-24",[4,6,4,7,4,3]) +> ,("8-25",[4,6,4,6,4,4]) +> ,("8-26",[4,5,6,5,6,2]) +> ,("8-27",[4,5,6,5,5,3]) +> ,("8-28",[4,4,8,4,4,4]) +> ,("8-Z29",[5,5,5,5,5,3]) +> ,("9-1",[8,7,6,6,6,3]) +> ,("9-2",[7,7,7,6,6,3]) +> ,("9-3",[7,6,7,7,6,3]) +> ,("9-4",[7,6,6,7,7,3]) +> ,("9-5",[7,6,6,6,7,4]) +> ,("9-6",[6,8,6,7,6,3]) +> ,("9-7",[6,7,7,6,7,3]) +> ,("9-8",[6,7,6,7,6,4]) +> ,("9-9",[6,7,6,6,8,3]) +> ,("9-10",[6,6,8,6,6,4]) +> ,("9-11",[6,6,7,7,7,3]) +> ,("9-12",[6,6,6,9,6,3]) +> ,("10-1",[9,8,8,8,8,4]) +> ,("10-2",[8,9,8,8,8,4]) +> ,("10-3",[8,8,9,8,8,4]) +> ,("10-4",[8,8,8,9,8,4]) +> ,("10-5",[8,8,8,8,9,4]) +> ,("10-6",[8,8,8,8,8,5]) +> ,("11-1",[10,10,10,10,10,5]) +> ,("12-1",[12,12,12,12,12,6])] +> in let icvs = map icv scs in zip (map sc_name scs) icvs == r + +-} scs :: [[Z12]] scs = map snd sc_table -- | Cardinality /n/ subset of 'scs'. -- --- > map (length . scs_n) [2..10] == [6,12,29,38,50,38,29,12,6] +-- > 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 @@ -326,23 +536,19 @@ -- > 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 = sort . map ic . d_dx +bip = Z.bip z12_modulo -- * ICV Metric -- | Interval class of Z12 interval /i/. -- -- > map ic [5,6,7] == [5,6,5] +-- > map ic [-13,-1,0,1,13] == [1,1,0,1,1] ic :: Z12 -> Z12 -ic i = if i <= 6 then i else 12 - i +ic = Z.ic z12_modulo -- | Forte notation for interval class vector. -- -- > icv [0,1,2,4,7,8] == [3,2,2,3,3,2] icv :: Integral i => [Z12] -> [i] -icv s = - let i = map (ic . uncurry (-)) (S.pairs s) - j = map f (group (sort i)) - k = map (`lookup` j) [1..6] - f l = (head l,genericLength l) - in map (fromMaybe 0) k +icv = Z.icv z12_modulo 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,11 +1,12 @@ -- | Parsers for pitch class sets and sequences, and for 'SRO's. module Music.Theory.Z12.Morris_1987.Parse (rnrtnmi,pco) where -import Control.Monad -import Data.Char +import Control.Monad {- base -} +import Data.Char {- base -} +import Text.ParserCombinators.Parsec {- parsec -} + import Music.Theory.Z12 import Music.Theory.Z12.Morris_1987 -import Text.ParserCombinators.Parsec -- | A 'Char' parser. type P a = GenParser Char () a @@ -26,14 +27,14 @@ -- > 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) } + 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)) 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 @@ -2,7 +2,7 @@ module Music.Theory.Z12.Rahn_1980 where import Music.Theory.Z12 -import Music.Theory.Z12.Forte_1973 +import qualified Music.Theory.Z.Forte_1973 as Z -- | Rahn prime form (comparison is rightmost inwards). -- @@ -14,10 +14,12 @@ -- -- > rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] -- +-- > import Music.Theory.Z12.Forte_1973 +-- -- > let s = [[0,1,3,7,8] -- > ,[0,1,3,6,8,9],[0,1,3,5,8,9] -- > ,[0,1,2,4,7,8,9] -- > ,[0,1,2,4,5,7,9,10]] -- > in all (\p -> forte_prime p /= rahn_prime p) s == True rahn_prime :: [Z12] -> [Z12] -rahn_prime = ti_cmp_prime rahn_cmp +rahn_prime = Z.ti_cmp_prime z12_modulo 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 @@ -3,29 +3,26 @@ -- Discrete Mathematics/ 2:107–20, 1978. module Music.Theory.Z12.Read_1978 where -import Data.Bits -import Music.Theory.Z12 -import Music.Theory.Z12.SRO +import Music.Theory.Z12 {- hmt -} +import qualified Music.Theory.Z.Read_1978 as Z {- hmt -} +type Code = Z.Code + -- | Encoder for 'encode_prime'. -- -- > encode [0,1,3,6,8,9] == 843 -encode :: [Z12] -> Integer -encode = sum . map ((2 ^) . (fromZ12::Z12->Integer)) +encode :: [Z12] -> Code +encode = Z.encode -- | Decoder for 'encode_prime'. -- -- > decode 843 == [0,1,3,6,8,9] -decode :: Integer -> [Z12] -decode n = - let f i = (i, testBit n i) - in map (toZ12 . fst) (filter snd (map f [0..11])) +decode :: Code -> [Z12] +decode = Z.decode 12 -- | Binary encoding prime form algorithm, equalivalent to Rahn. -- --- > encode_prime [0,1,3,6,8,9] == rahn_prime [0,1,3,6,8,9] +-- > encode_prime [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 s = - let t = map (`tn` s) [0..11] - c = t ++ map (invert 0) t - in decode (minimum (map encode c)) +encode_prime = Z.encode_prime z12_modulo 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 @@ -3,33 +3,34 @@ import Data.List import qualified Music.Theory.List as T +import qualified Music.Theory.Z.SRO as Z import Music.Theory.Z12 -- | Transpose /p/ by /n/. -- -- > tn 4 [1,5,6] == [5,9,10] tn :: Z12 -> [Z12] -> [Z12] -tn n = fmap (+ n) +tn = Z.tn z12_modulo -- | Invert /p/ about /n/. -- -- > invert 6 [4,5,6] == [8,7,6] -- > invert 0 [0,1,3] == [0,11,9] invert :: Z12 -> [Z12] -> [Z12] -invert n = fmap (\p -> n - (p - n)) +invert = Z.invert z12_modulo -- | Composition of 'invert' about @0@ and 'tn'. -- -- > tni 4 [1,5,6] == [3,11,10] -- > (invert 0 . tn 4) [1,5,6] == [7,3,2] tni :: Z12 -> [Z12] -> [Z12] -tni n = tn n . invert 0 +tni = Z.tni z12_modulo -- | Modulo 12 multiplication -- -- > mn 11 [0,1,4,9] == tni 0 [0,1,4,9] mn :: Z12 -> [Z12] -> [Z12] -mn n = fmap (* n) +mn = Z.mn z12_modulo -- | M5, ie. 'mn' @5@. -- @@ -41,7 +42,7 @@ -- -- > length (t_related [0,3,6,9]) == 12 t_related :: [Z12] -> [[Z12]] -t_related p = fmap (`tn` p) [0..11] +t_related = Z.t_related z12_modulo -- | T\/I-related sequences of /p/. -- @@ -49,14 +50,14 @@ -- > length (ti_related [0,3,6,9]) == 24 -- > ti_related [0] == map return [0..11] ti_related :: [Z12] -> [[Z12]] -ti_related p = nub (t_related p ++ t_related (invert 0 p)) +ti_related = Z.ti_related z12_modulo -- | R\/T\/I-related sequences of /p/. -- -- > length (rti_related [0,1,3]) == 48 -- > length (rti_related [0,3,6,9]) == 24 rti_related :: [Z12] -> [[Z12]] -rti_related p = let q = ti_related p in nub (q ++ map reverse q) +rti_related = Z.rti_related z12_modulo -- | T\/M\/I-related sequences of /p/. tmi_related :: [Z12] -> [[Z12]] @@ -75,18 +76,16 @@ -- | 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 n p = - case p of - [] -> [] - x:xs -> n : tn (n - x) xs +tn_to = Z.tn_to z12_modulo -- | Variant of 'invert', inverse about /n/th element. -- -- > map (invert_ix 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] -- > map (invert_ix 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] invert_ix :: Int -> [Z12] -> [Z12] -invert_ix n p = invert (p!!n) p +invert_ix = Z.invert_ix z12_modulo -- | The standard t-matrix of /p/. -- @@ -94,4 +93,4 @@ -- > ,[11,0,2] -- > ,[9,10,0]] tmatrix :: [Z12] -> [[Z12]] -tmatrix p = map (`tn` p) (tn_to 0 (invert_ix 0 p)) +tmatrix = Z.tmatrix z12_modulo diff --git a/README b/README --- a/README +++ b/README @@ -9,7 +9,7 @@ [hs]: http://haskell.org/ [hmt-diagrams]: http://rd.slavepianos.org/?t=hmt-diagrams -© [rohan drape][rd], 2006-2013, [gpl][gpl]. +© [rohan drape][rd], 2006-2014, [gpl][gpl]. [rd]: http://rd.slavepianos.org/ [gpl]: http://gnu.org/copyleft/ diff --git a/hmt.cabal b/hmt.cabal --- a/hmt.cabal +++ b/hmt.cabal @@ -1,15 +1,15 @@ Name: hmt -Version: 0.14 +Version: 0.15 Synopsis: Haskell Music Theory Description: Haskell music theory library License: GPL Category: Music -Copyright: Rohan Drape, 2006-2013 +Copyright: Rohan Drape, 2006-2014 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental -Homepage: http://rd.slavepianos.org/?t=hmt -Tested-With: GHC == 7.6.1 +Homepage: http://rd.slavepianos.org/t/hmt +Tested-With: GHC == 7.8.2 Build-Type: Simple Cabal-Version: >= 1.8 @@ -17,27 +17,35 @@ Help/hmt.help.lhs Library - Build-Depends: base==4.*, + Build-Depends: array, + base == 4.*, bytestring, colour, containers, + data-ordlist, directory, filepath, + lazy-csv, logict, multiset-comb, parsec, permutation, primes, + safe, split, utf8-string GHC-Options: -Wall -fwarn-tabs - Exposed-modules: Music.Theory.Bjorklund + Exposed-modules: Music.Theory.Array.CSV + Music.Theory.Array.CSV.Midi + Music.Theory.Array.MD + Music.Theory.Bjorklund Music.Theory.Block_Design.Johnson_2007 Music.Theory.Clef Music.Theory.Combinations Music.Theory.Contour.Polansky_1992 Music.Theory.Duration Music.Theory.Duration.Annotation + Music.Theory.Duration.CT Music.Theory.Duration.Name Music.Theory.Duration.Name.Abbreviation Music.Theory.Duration.RQ @@ -45,38 +53,63 @@ Music.Theory.Duration.RQ.Tied Music.Theory.Duration.Sequence.Notate Music.Theory.Dynamic_Mark + Music.Theory.Either + Music.Theory.Function + Music.Theory.Instrument.Choir Music.Theory.Interval Music.Theory.Interval.Barlow_1987 Music.Theory.Interval.Name Music.Theory.Interval.Spelling - Music.Theory.Pitch.Spelling.Cluster Music.Theory.Key Music.Theory.List + Music.Theory.Math + Music.Theory.Maybe Music.Theory.Meter.Barlow_1987 Music.Theory.Metric.Buchler_1998 Music.Theory.Metric.Morris_1980 Music.Theory.Metric.Polansky_1996 Music.Theory.Permutations Music.Theory.Permutations.List + Music.Theory.Permutations.Morris_1984 Music.Theory.Pitch Music.Theory.Pitch.Name + Music.Theory.Pitch.Note Music.Theory.Pitch.Spelling + Music.Theory.Pitch.Spelling.Cluster Music.Theory.Set.List Music.Theory.Set.Set Music.Theory.Tempo_Marking Music.Theory.Tiling.Canon Music.Theory.Tiling.Johnson_2004 Music.Theory.Tiling.Johnson_2009 + Music.Theory.Time.Bel1990.R + Music.Theory.Time.Duration + Music.Theory.Time.Notation + Music.Theory.Time.Seq Music.Theory.Time_Signature + Music.Theory.Tuple Music.Theory.Tuning + Music.Theory.Tuning.Alves Music.Theory.Tuning.Alves_1997 + Music.Theory.Tuning.ET + Music.Theory.Tuning.Gann Music.Theory.Tuning.Meyer_1929 + Music.Theory.Tuning.Microtonal_Synthesis Music.Theory.Tuning.Polansky_1978 Music.Theory.Tuning.Polansky_1984 + Music.Theory.Tuning.Polansky_1985c Music.Theory.Tuning.Polansky_1990 + Music.Theory.Tuning.Riley Music.Theory.Tuning.Scala + Music.Theory.Tuning.Syntonic + Music.Theory.Tuning.Werckmeister + Music.Theory.Unicode Music.Theory.Xenakis.S4 Music.Theory.Xenakis.Sieve + Music.Theory.Z + Music.Theory.Z.Forte_1973 + Music.Theory.Z.Read_1978 + Music.Theory.Z.SRO Music.Theory.Z12 Music.Theory.Z12.Castren_1994 Music.Theory.Z12.Drape_1999