hmt 0.14 → 0.15

raw patch · 65 files changed

+6427/−1058 lines, 65 filesdep +arraydep +data-ordlistdep +lazy-csvPVP ok

version bump matches the API change (PVP)

Dependencies added: array, data-ordlist, lazy-csv, safe

API changes (from Hackage documentation)

Files

• Music/Theory/Array/CSV.hs +346/−0
• Music/Theory/Array/CSV/Midi.hs +86/−0
• Music/Theory/Array/MD.hs +111/−0
• Music/Theory/Block_Design/Johnson_2007.hs +9/−8
• Music/Theory/Clef.hs +8/−3
• Music/Theory/Contour/Polansky_1992.hs +5/−4
• Music/Theory/Duration.hs +21/−4
• Music/Theory/Duration/Annotation.hs +6/−6
• Music/Theory/Duration/CT.hs +195/−0
• Music/Theory/Duration/RQ.hs +9/−6
• Music/Theory/Duration/Sequence/Notate.hs +127/−72
• Music/Theory/Dynamic_Mark.hs +74/−5
• Music/Theory/Either.hs +16/−0
• Music/Theory/Function.hs +52/−0
• Music/Theory/Instrument/Choir.hs +143/−0
• Music/Theory/Interval.hs +89/−9
• Music/Theory/Interval/Barlow_1987.hs +7/−11
• Music/Theory/Interval/Spelling.hs +12/−11
• Music/Theory/Key.hs +3/−1
• Music/Theory/List.hs +189/−36
• Music/Theory/Math.hs +98/−0
• Music/Theory/Maybe.hs +80/−0
• Music/Theory/Meter/Barlow_1987.hs +3/−4
• Music/Theory/Metric/Buchler_1998.hs +15/−14
• Music/Theory/Permutations.hs +3/−2
• Music/Theory/Permutations/Morris_1984.hs +216/−0
• Music/Theory/Pitch.hs +191/−194
• Music/Theory/Pitch/Name.hs +37/−0
• Music/Theory/Pitch/Note.hs +224/−0
• Music/Theory/Pitch/Spelling.hs +1/−1
• Music/Theory/Tempo_Marking.hs +44/−0
• Music/Theory/Time/Bel1990/R.hs +642/−0
• Music/Theory/Time/Duration.hs +148/−0
• Music/Theory/Time/Notation.hs +43/−0
• Music/Theory/Time/Seq.hs +760/−0
• Music/Theory/Time_Signature.hs +94/−1
• Music/Theory/Tuning.hs +210/−446
• Music/Theory/Tuning/Alves.hs +25/−0
• Music/Theory/Tuning/ET.hs +248/−0
• Music/Theory/Tuning/Gann.hs +141/−0
• Music/Theory/Tuning/Microtonal_Synthesis.hs +205/−0
• Music/Theory/Tuning/Polansky_1984.hs +2/−2
• Music/Theory/Tuning/Polansky_1985c.hs +35/−0
• Music/Theory/Tuning/Riley.hs +18/−0
• Music/Theory/Tuning/Scala.hs +8/−8
• Music/Theory/Tuning/Syntonic.hs +60/−0
• Music/Theory/Tuning/Werckmeister.hs +105/−0
• Music/Theory/Tuple.hs +258/−0
• Music/Theory/Unicode.hs +56/−0
• Music/Theory/Xenakis/S4.hs +8/−7
• Music/Theory/Xenakis/Sieve.hs +37/−24
• Music/Theory/Z.hs +94/−0
• Music/Theory/Z/Forte_1973.hs +101/−0
• Music/Theory/Z/Read_1978.hs +144/−0
• Music/Theory/Z/SRO.hs +83/−0
• Music/Theory/Z12.hs +87/−20
• Music/Theory/Z12/Castren_1994.hs +20/−25
• Music/Theory/Z12/Drape_1999.hs +45/−42
• Music/Theory/Z12/Forte_1973.hs +250/−44
• Music/Theory/Z12/Morris_1987/Parse.hs +12/−11
• Music/Theory/Z12/Rahn_1980.hs +4/−2
• Music/Theory/Z12/Read_1978.hs +11/−14
• Music/Theory/Z12/SRO.hs +12/−13
• README +1/−1
• hmt.cabal +40/−7

@@ -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)

@@ -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'

@@ -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

@@ -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

@@ -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'

@@ -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) 

@@ -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))

@@ -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 

@@ -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))

@@ -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

@@ -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

@@ -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) +-- | <http://www.csounds.com/manual/html/ampmidid.html>+--+-- > 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

@@ -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

@@ -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 . (.::::)+

@@ -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)

@@ -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)

@@ -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.

@@ -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'

@@ -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.

@@ -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)

@@ -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++-- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html>+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++-- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html>+--+-- > 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++-- | <http://reference.wolfram.com/mathematica/ref/SawtoothWave.html>+--+-- > 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

@@ -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

@@ -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

@@ -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)] 

@@ -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. --

@@ -0,0 +1,216 @@+-- | Place notation (method ringing).+--+-- Morris, R. G. T. "Place Notation"+-- Central Council of Church Bell Ringers (1984).+-- <http://www.cccbr.org.uk/bibliography/>+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.+--+-- <https://rsw.me.uk/blueline/methods/view/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.+--+-- <https://rsw.me.uk/blueline/methods/view/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+--+-- <https://rsw.me.uk/blueline/methods/view/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.+--+-- <https://rsw.me.uk/blueline/methods/view/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.+--+-- <https://rsw.me.uk/blueline/methods/view/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

@@ -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 <http://www.musiccog.ohio-state.edu/Humdrum/guide04.html>+--+-- > 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'

@@ -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

@@ -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 <http://www.musiccog.ohio-state.edu/Humdrum/guide04.html> and+-- <http://lilypond.org/doc/v2.16/Documentation/notation/writing-pitches>+--+-- > 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)+

@@ -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)

@@ -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).+-- <http://wittner-gmbh.de/>+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).+-- <http://nikkoseiki.com/>+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)

@@ -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.+  (<http://hal.archives-ouvertes.fr/hal-00134160>)++- Bernard Bel.+  \"Two algorithms for the instantiation of structures of musical objects\".+  Centre National de la Recherche Scientifique, 1992. /GRTC 458/+  (<http://www.lpl.univ-aix.fr/~belbernard/music/2algorithms.pdf>)++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)

@@ -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')

@@ -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]

@@ -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

@@ -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))

@@ -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 <http://www.billalves.com/porgitaro/ditonesettuning.html>------ > 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--- <http://www.kylegann.com/histune.html>------ > 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--- <http://www.kylegann.com/tuning.html>.------ > 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--- <http://www.kylegann.com/tuning.html>------ > 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--- <http://www.microtonal-synthesis.com/scale_harrison_16.html>------ > 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--- <http://www.microtonal-synthesis.com/scale_partch.html>------ > 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 (@<sup>@).+cents_diff_html :: (Num a, Ord a, Show a) => a -> String+cents_diff_html = cents_diff_br ("<SUP>","</SUP>")++-- * 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

@@ -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 <http://www.billalves.com/porgitaro/ditonesettuning.html>+--+-- > 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

@@ -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).+-- <http://www.tonalsoft.com/enc/number/72edo.aspx>+--+-- > 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)

@@ -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+-- <http://www.kylegann.com/histune.html>+--+-- > 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), <http://www.kylegann.com/histune.html>.+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, <http://www.kylegann.com/histune.html>.+--+-- > 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 <http://www.kylegann.com/tuning.html>.+--+-- > 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+-- <http://www.kylegann.com/wtp.html>.+--+-- > 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+-- <http://www.kylegann.com/tuning.html>+--+-- > 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 <http://www.kylegann.com/Arcana.html>.+--+-- > 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 <http://www.kylegann.com/Super.html>.+--+-- > 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

@@ -0,0 +1,205 @@+-- | <http://www.microtonal-synthesis.com/scales.html>+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, <http://www.microtonal-synthesis.com/scale_pythagorean.html>.+--+-- > 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+-- <http://www.microtonal-synthesis.com/scale_just_intonation.html>+--+-- > 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]++-- | <http://www.microtonal-synthesis.com/scale_kirnberger.html>.+--+-- > 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+-- <http://www.microtonal-synthesis.com/scale_vallotti_young.html>.+--+-- > 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,+-- <http://www.microtonal-synthesis.com/scale_reinhard.html>.+--+-- > 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+-- <http://www.microtonal-synthesis.com/scale_harrison_16.html>+--+-- > 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+-- <http://www.microtonal-synthesis.com/scale_partch.html>+--+-- > 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+-- <http://www.microtonal-synthesis.com/scale_johnston_25.html>+ben_johnston_25 :: Tuning+ben_johnston_25 = Tuning (Left ben_johnston_25_r) 2