packages feed

hmt 0.16 → 0.18

raw patch · 156 files changed

+11231/−4873 lines, 156 filesdep +hsc3dep +processdep +timedep −modular-arithmetic

Dependencies added: hsc3, process, time

Dependencies removed: modular-arithmetic

Files

Music/Theory/Array.hs view
@@ -1,3 +1,4 @@+-- | Array & table functions module Music.Theory.Array where  import Data.List {- base -}@@ -7,20 +8,48 @@  -- * Association List (List Array) +-- | 'T.minmax' of /k/. larray_bounds :: Ord k => [(k,v)] -> (k,k) larray_bounds = T.minmax . map fst +-- | 'A.array' of association list. larray :: A.Ix k => [(k,v)] -> A.Array k v larray a = A.array (larray_bounds a) a  -- * List Table +-- | 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]]++-- | Table row count.+tbl_rows :: Table t -> Int+tbl_rows = length++-- | Table column count, assumes table is regular.+tbl_columns :: Table t -> Int+tbl_columns tbl =+  case tbl of+    [] -> 0+    r0:_ -> length r0++-- | Determine is table is regular, ie. all rows have the same number of columns.+--+-- > tbl_is_regular [[0..3],[4..7],[8..11]] == True+tbl_is_regular :: Table t -> Bool+tbl_is_regular = (== 1) . length . nub . map length++-- | Map /f/ at table, padding short rows with /k/.+tbl_make_regular :: (t -> u,u) -> Table t -> Table u+tbl_make_regular (f,k) tbl =+    let z = maximum (map length tbl)+    in map (T.pad_right k z) (map (map f) tbl)+ -- | Append a sequence of /nil/ (or default) values to each row of /tbl/ -- so to make it regular (ie. all rows of equal length).-make_regular :: t -> [[t]] -> [[t]]-make_regular k tbl =-    let z = maximum (map length tbl)-    in map (T.pad_right k z) tbl+tbl_make_regular_nil :: t -> Table t -> Table t+tbl_make_regular_nil k = tbl_make_regular (id,k)  -- * Matrix Indices
Music/Theory/Array/CSV.hs view
@@ -1,16 +1,38 @@ -- | Regular matrix array data, CSV, column & row indexing. module Music.Theory.Array.CSV where -import qualified Data.Array as A {- array -} import Data.List {- base -} +import qualified Data.Array as A {- array -}+import qualified Safe {- safe -} import qualified Text.CSV.Lazy.String as C {- lazy-csv -} -import qualified Music.Theory.Array.Cell_Ref as T {- hmt -}+import qualified Music.Theory.Array as T {- hmt -}+import qualified Music.Theory.Array.Cell_Ref as R {- hmt -} import qualified Music.Theory.IO as T {- hmt -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Tuple as T {- hmt -} +-- * FIELD / QUOTE++-- | Quoting is required is the string has a double-quote, comma newline or carriage-return.+csv_requires_quote :: String -> Bool+csv_requires_quote = any (`elem` "\",\n\r")++-- | Quoting places double-quotes at the start and end and escapes double-quotes.+csv_quote :: String -> String+csv_quote fld =+  let esc s =+        case s of+          [] -> []+          '"':s' -> '"' : '"' : esc s'+          c:s' -> c : esc s'+  in '"' : esc fld ++ "\""++-- | Quote field if required.+csv_quote_if_req :: String -> String+csv_quote_if_req fld = if csv_requires_quote fld then csv_quote fld else fld+ -- * TABLE  -- | When reading a CSV file is the first row a header?@@ -34,13 +56,8 @@ 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 'Maybe' a header.-type CSV_Table a = (Maybe [String],Table a)+type CSV_Table a = (Maybe [String],T.Table a)  -- | Read 'CSV_Table' from @CSV@ file. csv_table_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (CSV_Table a)@@ -51,10 +68,14 @@       (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_def :: (String -> a) -> FilePath -> IO (Table a)+-- | Read 'T.Table' only with 'def_csv_opt'.+csv_table_read_def :: (String -> a) -> FilePath -> IO (T.Table a) csv_table_read_def f = fmap snd . csv_table_read def_csv_opt f +-- | Read plain CSV 'T.Table'.+csv_table_read_plain :: FilePath -> IO (T.Table String)+csv_table_read_plain = csv_table_read_def id+ -- | Read and process @CSV@ 'CSV_Table'. csv_table_with :: CSV_Opt -> (String -> a) -> FilePath -> (CSV_Table a -> b) -> IO b csv_table_with opt f fn g = fmap g (csv_table_read opt f fn)@@ -62,7 +83,7 @@ -- | Align table according to 'CSV_Align_Columns'. -- -- > csv_table_align CSV_No_Align [["a","row","and"],["then","another","one"]]-csv_table_align :: CSV_Align_Columns -> Table String -> Table String+csv_table_align :: CSV_Align_Columns -> T.Table String -> T.Table String csv_table_align align tbl =     let c = transpose tbl         n = map (maximum . map length) c@@ -85,43 +106,47 @@ csv_table_write f opt fn csv = T.write_file_utf8 fn (csv_table_pp f opt csv)  -- | Write 'Table' only (no header) with 'def_csv_opt'.-csv_table_write_def :: (a -> String) -> FilePath -> Table a -> IO ()+csv_table_write_def :: (a -> String) -> FilePath -> T.Table a -> IO () csv_table_write_def f fn tbl = csv_table_write f def_csv_opt fn (Nothing,tbl) +-- | Write plain CSV 'Table'.+csv_table_write_plain :: FilePath -> T.Table String -> IO ()+csv_table_write_plain = csv_table_write_def id+ -- | @0@-indexed (row,column) cell lookup.-table_lookup :: Table a -> (Int,Int) -> a-table_lookup t (r,c) = (t !! r) !! c+table_lookup :: T.Table a -> (Int,Int) -> a+table_lookup t (r,c) = let ix = Safe.atNote "table_lookup" in (t `ix` r) `ix` c  -- | Row data.-table_row :: Table a -> T.Row_Ref -> [a]-table_row t r = t !! T.row_index r+table_row :: T.Table a -> R.Row_Ref -> [a]+table_row t r = Safe.atNote "table_row" t (R.row_index r)  -- | Column data.-table_column :: Table a -> T.Column_Ref -> [a]-table_column t c = transpose t !! T.column_index c+table_column :: T.Table a -> R.Column_Ref -> [a]+table_column t c = Safe.atNote "table_column" (transpose t) (R.column_index c)  -- | Lookup value across columns.-table_column_lookup :: Eq a => Table a -> (T.Column_Ref,T.Column_Ref) -> a -> Maybe a+table_column_lookup :: Eq a => T.Table a -> (R.Column_Ref,R.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 -> T.Cell_Ref -> a+table_cell :: T.Table a -> R.Cell_Ref -> a table_cell t (c,r) =-    let (r',c') = (T.row_index r,T.column_index c)+    let (r',c') = (R.row_index r,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.Table a -> (Int,(Int,Int)) -> [a] table_lookup_row_segment t (r,(c0,c1)) =-    let r' = t !! r+    let r' = Safe.atNote "table_lookup_row_segment" t r     in take (c1 - c0 + 1) (drop c0 r')  -- | Range of cells from row.-table_row_segment :: Table a -> (T.Row_Ref,T.Column_Range) -> [a]+table_row_segment :: T.Table a -> (R.Row_Ref,R.Column_Range) -> [a] table_row_segment t (r,c) =-    let (r',c') = (T.row_index r,T.column_indices c)+    let (r',c') = (R.row_index r,R.column_indices c)     in table_lookup_row_segment t (r',c')  -- * Array@@ -135,16 +160,16 @@ -- > > (((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 -> A.Array T.Cell_Ref a+table_to_array :: T.Table a -> A.Array R.Cell_Ref a table_to_array t =     let nr = length t-        nc = length (t !! 0)-        bnd = (T.cell_ref_minima,(toEnum (nc - 1),nr))-        asc = zip (T.cell_range_row_order bnd) (concat t)+        nc = length (Safe.atNote "table_to_array" t 0)+        bnd = (R.cell_ref_minima,(toEnum (nc - 1),nr))+        asc = zip (R.cell_range_row_order bnd) (concat t)     in A.array bnd asc  -- | 'table_to_array' of 'csv_table_read'.-csv_array_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (A.Array T.Cell_Ref a)+csv_array_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (A.Array R.Cell_Ref a) csv_array_read opt f fn = fmap (table_to_array . snd) (csv_table_read opt f fn)  -- * Irregular@@ -174,6 +199,14 @@ csv_load_irregular f fn = do   s <- T.read_file_utf8 fn   return (map (map (f . csv_field_str) . csv_row_recover) (C.parseCSV s))++csv_write_irregular :: (a -> String) -> CSV_Opt -> FilePath -> CSV_Table a -> IO ()+csv_write_irregular f opt fn (hdr,tbl) =+  let tbl' = T.tbl_make_regular_nil "" (map (map f) tbl)+  in T.write_file_utf8 fn (csv_table_pp id opt (hdr,tbl'))++csv_write_irregular_def :: (a -> String) -> FilePath -> T.Table a -> IO ()+csv_write_irregular_def f fn tbl = csv_write_irregular f def_csv_opt fn (Nothing,tbl)  -- * Tuples
Music/Theory/Array/CSV/Midi/MND.hs view
@@ -4,14 +4,16 @@ -- Non-integral note number and key velocity data are allowed. module Music.Theory.Array.CSV.Midi.MND where -import Data.List.Split {- split -}-import Data.List {- base -}+import Data.Function {- base -} import Data.Maybe {- base -} import Data.Word {- base -} +import Sound.SC3.Server.Param {- hsc3 -}+ import qualified Music.Theory.Array.CSV as T {- hmt -} import qualified Music.Theory.Math as T {- hmt -} import qualified Music.Theory.Read as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -} import qualified Music.Theory.Time.Seq as T {- hmt -}  -- | If /r/ is whole to /k/ places then show as integer, else as float to /k/ places.@@ -28,50 +30,43 @@ csv_mnd_hdr :: [String] csv_mnd_hdr = ["time","on/off","note","velocity","channel","param"] -type Param = (String,Double)--param_parse :: String -> [Param]-param_parse str =-    let f x = case splitOn "=" x of-                [lhs,rhs] -> (lhs,read rhs)-                _ -> error ("param_parse: " ++ x)-    in if null str then [] else map f (splitOn ";" str)--param_pp :: Int -> [Param] -> String-param_pp k =-    let f (lhs,rhs) = concat [lhs,"=",T.real_pp k rhs]-    in intercalate ";" . map f- -- | Midi note data, the type parameters are to allow for fractional note & velocity values. -- The command is a string, @on@ and @off@ are standard, other commands may be present. -- -- > unwords csv_mnd_hdr == "time on/off note velocity channel param"-type MND t n = (t,String,n,n,Channel,[Param])+--+-- > all_notes_off = zipWith (\t k -> (t,"off",k,0,0,[])) [0.0,0.01 ..] [0 .. 127]+-- > csv_mnd_write 4 "/home/rohan/sw/hmt/data/csv/mnd/all-notes-off.csv" all_notes_off+type MND t n = (t,String,n,n,Channel,Param) -csv_mnd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MND t n]-csv_mnd_parse (hdr,dat) =+csv_mnd_parse_f :: (Read t,Real t,Read n,Real n) => (n -> m) -> T.CSV_Table String -> [MND t m]+csv_mnd_parse_f cnv (hdr,dat) =     let err x = error ("csv_mnd_read: " ++ x)         f m = case m of                 [st,msg,mnn,vel,ch,pm] ->                     (T.reads_exact_err "time:real" st                     ,msg-                    ,T.reads_exact_err "note:real" mnn-                    ,T.reads_exact_err "velocity:real" vel+                    ,cnv (T.reads_exact_err "note:real" mnn)+                    ,cnv (T.reads_exact_err "velocity:real" vel)                     ,T.reads_exact_err "channel:int" ch-                    ,param_parse pm)+                    ,param_parse (';','=') pm)                 _ -> err "entry?"     in case hdr of          Just hdr' -> if hdr' == csv_mnd_hdr then map f dat else err "header?"          Nothing -> err "no header?" +csv_mnd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MND t n]+csv_mnd_parse = csv_mnd_parse_f id+ load_csv :: FilePath -> IO (T.CSV_Table String) load_csv = T.csv_table_read (True,',',False,T.CSV_No_Align) id  -- | Midi note data. -- -- > let fn = "/home/rohan/cvs/uc/uc-26/daily-practice/2014-08-13.1.csv"--- > m <- csv_mnd_read fn :: IO [MND Double Double]--- > length m == 17655+-- > let fn = "/home/rohan/sw/hmt/data/csv/mnd/1080-C01.csv"+-- > m <- csv_mnd_read fn :: IO [MND Double Int]+-- > length m -- 1800 17655 -- > csv_mnd_write 4 "/tmp/t.csv" m csv_mnd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MND t n] csv_mnd_read = fmap csv_mnd_parse . load_csv@@ -85,15 +80,39 @@             ,data_value_pp r_prec mnn             ,data_value_pp r_prec vel             ,show ch-            ,param_pp r_prec pm]+            ,param_pp (';','=') r_prec pm]         with_hdr dat = (Just csv_mnd_hdr,dat)     in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node  -- * MND Seq forms  -- | (p0=midi-note,p1=velocity,channel,param)-type Event n = (n,n,Channel,[Param])+type Event n = (n,n,Channel,Param) +-- | mnn = midi-note-number+event_mnn :: Event t -> t+event_mnn (mnn,_,_,_) = mnn++-- | ch = channel+event_ch :: Event t -> Channel+event_ch (_,_,ch,_) = ch++-- | Are events equal at mnn and ch fields?+event_eq_ol :: Eq t => Event t -> Event t -> Bool+event_eq_ol = ((==) `on` (\(mnn,_,ch,_) -> (mnn,ch)))++-- | Apply (mnn-f,vel-f,ch-f,param-f) to Event.+event_map :: (t -> u,t -> u,Channel -> Channel,Param -> Param) -> Event t -> Event u+event_map (f1,f2,f3,f4) (mnn,vel,ch,param) = (f1 mnn,f2 vel,f3 ch,f4 param)++-- | Apply /f/ at mnn and vel fields.+event_cast :: (t -> u) -> Event t -> Event u+event_cast f = event_map (f,f,id,id)++-- | Add /x/ to mnn field.+event_transpose :: Num a => a -> Event a -> Event a+event_transpose x = event_map ((+) x,id,id,id)+ -- | Translate from 'Tseq' form to 'Wseq' form. midi_tseq_to_midi_wseq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (Event n)) -> T.Wseq t (Event n) midi_tseq_to_midi_wseq = T.tseq_begin_end_to_wseq (\(n0,_,c0,_) (n1,_,c1,_) -> c0 == c1 && n0 == n1)@@ -129,11 +148,23 @@ csv_mndd_hdr :: [String] csv_mndd_hdr = ["time","duration","message","note","velocity","channel","param"] +-- | Midi note/duration data.+-- The type parameters are to allow for fractional note & velocity values.+-- The command is a string, @note@ is standard, other commands may be present.+-- -- > unwords csv_mndd_hdr == "time duration message note velocity channel param"-type MNDD t n = (t,t,String,n,n,Channel,[Param])+type MNDD t n = (t,t,String,n,n,Channel,Param) -csv_mndd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MNDD t n]-csv_mndd_parse (hdr,dat) =+-- | Compare sequence is: start-time,channel-number,note-number,velocity,duration,param.+mndd_compare :: (Ord t,Ord n) => MNDD t n -> MNDD t n -> Ordering+mndd_compare x1 x2 =+  case (x1,x2) of+    ((t1,d1,"note",n1,v1,c1,p1),(t2,d2,"note",n2,v2,c2,p2)) ->+      compare (t1,c1,n1,v1,d1,p1) (t2,c2,n2,v2,d2,p2)+    _ -> compare x1 x2++csv_mndd_parse_f :: (Read t,Real t,Read n,Real n) => (n -> m) -> T.CSV_Table String -> [MNDD t m]+csv_mndd_parse_f cnv (hdr,dat) =     let err x = error ("csv_mndd_read: " ++ x)         f m =             case m of@@ -141,16 +172,20 @@                   (T.reads_exact_err "time" st                   ,T.reads_exact_err "duration" du                   ,msg-                  ,T.reads_exact_err "note" mnn-                  ,T.reads_exact_err "velocity" vel+                  ,cnv (T.reads_exact_err "note" mnn)+                  ,cnv (T.reads_exact_err "velocity" vel)                   ,T.reads_exact_err "channel" ch-                  ,param_parse pm)+                  ,param_parse (';','=') pm)               _ -> err "entry?"     in case hdr of          Just hdr' -> if hdr' == csv_mndd_hdr then map f dat else err "header?"          Nothing -> err "no header?" --- | Midi note/duration data.+-- | Pars midi note/duration data from CSV table.+csv_mndd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MNDD t n]+csv_mndd_parse = csv_mndd_parse_f id++-- | 'csv_mndd_parse' of 'load_csv' csv_mndd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MNDD t n] csv_mndd_read = fmap csv_mndd_parse . load_csv @@ -161,7 +196,7 @@             [T.real_pp r_prec st,T.real_pp r_prec du,msg             ,data_value_pp r_prec mnn,data_value_pp r_prec vel             ,show ch-            ,param_pp r_prec pm]+            ,param_pp (';','=') r_prec pm]         with_hdr dat = (Just csv_mndd_hdr,dat)     in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node @@ -189,15 +224,18 @@ -- * Composite  -- | Parse either MND or MNDD data to Wseq, CSV type is decided by header.-csv_midi_parse_wseq :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> T.Wseq t (Event n)-csv_midi_parse_wseq (hdr,dat) = do+csv_midi_parse_wseq_f :: (Read t,Real t,Read n,Real n,Num m, Eq m) => (n -> m) -> T.CSV_Table String -> T.Wseq t (Event m)+csv_midi_parse_wseq_f cnv (hdr,dat) = do   case hdr of     Just hdr' -> if hdr' == csv_mnd_hdr-                 then midi_tseq_to_midi_wseq (mnd_to_tseq (csv_mnd_parse (hdr,dat)))+                 then midi_tseq_to_midi_wseq (mnd_to_tseq (csv_mnd_parse_f cnv (hdr,dat)))                  else if hdr' == csv_mndd_hdr-                      then mndd_to_wseq (csv_mndd_parse (hdr,dat))+                      then mndd_to_wseq (csv_mndd_parse_f cnv (hdr,dat))                       else error "csv_midi_read_wseq: not MND or MNDD"     _ -> error "csv_midi_read_wseq: header?"++csv_midi_parse_wseq :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> T.Wseq t (Event n)+csv_midi_parse_wseq = csv_midi_parse_wseq_f id  csv_midi_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n)) csv_midi_read_wseq = fmap csv_midi_parse_wseq . load_csv
+ Music/Theory/Array/CSV/Midi/SKINI.hs view
@@ -0,0 +1,57 @@+-- | Functions (partial) for reading & writing SKINI data files.+--+-- <https://ccrma.stanford.edu/software/stk/skini.html>+module Music.Theory.Array.CSV.Midi.SKINI where++import Data.List {- base -}++import qualified Music.Theory.Array.CSV.Midi.MND as T {- hmt -}+import qualified Music.Theory.Time.Seq as T {- hmt -}++-- | SKINI allows delta or absolute time-stamps.+data TIME t = Delta t | Absolute t++-- | SKINI data type of (message,time-stamp,channel,data-one,data-two)+type SKINI t n = (String,TIME t,T.Channel,n,n)++mnd_msg_to_skini_msg :: String -> String+mnd_msg_to_skini_msg msg =+  case msg of+    "on" -> "NoteOn"+    "off" -> "NoteOff"+    _ -> error "mnd_msg_to_skini_msg"++mnd_to_skini_f :: (t -> TIME t) -> T.MND t n -> SKINI t n+mnd_to_skini_f f mnd =+  case mnd of+    (t,msg,d1,d2,ch,[]) -> (mnd_msg_to_skini_msg msg,f t,ch,d1,d2)+    _ -> error "mnd_to_skini"++mnd_to_skini_abs :: T.MND t n -> SKINI t n+mnd_to_skini_abs = mnd_to_skini_f Absolute++midi_tseq_to_skini_seq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (T.Event n)) -> [SKINI t n]+midi_tseq_to_skini_seq =+  let f e =+        case e of+          (t,(T.Begin (d1,d2,ch,[]))) -> ("NoteOn",Delta t,ch,d1,d2)+          (t,(T.End (d1,d2,ch,[]))) -> ("NoteOff",Delta t,ch,d1,d2)+          _ -> error "midi_tseq_to_skini_seq"+  in map f . T.tseq_to_iseq++time_pp :: Real t => Int -> TIME t -> String+time_pp k t =+  case t of+    Delta x -> T.data_value_pp k x+    Absolute x -> '=' : T.data_value_pp k x++skini_pp_csv :: (Real t,Real n) => Int -> SKINI t n -> String+skini_pp_csv k (msg,t,ch,d1,d2) =+  let f = T.data_value_pp k+  in intercalate "," [msg,time_pp k t,show ch,f d1,f d2]++-- > let fn = "/home/rohan/sw/hmt/data/csv/mnd/1080-C01.csv"+-- > m <- T.csv_mnd_read_tseq fn :: IO (T.Tseq Double (T.Begin_End (T.Event Int)))+-- > skini_write_csv 4 "/tmp/t.skini" (midi_tseq_to_skini_seq m)+skini_write_csv :: (Real t,Real n) => Int -> FilePath -> [SKINI t n] -> IO ()+skini_write_csv k fn = writeFile fn . unlines . map (skini_pp_csv k)
− Music/Theory/Array/MD.hs 
@@ -1,108 +0,0 @@--- | Regular array data as markdown (MD) tables.-module Music.Theory.Array.MD where--import Data.List {- base -}--import qualified Music.Theory.Array as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.String as T {- hmt -}---- | 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/ and /eq_width/.------ > let tbl = [["a","bc","def"],["ghij","klm","no","p"]]--- > putStrLn$unlines$"": md_table_opt (True,True," · ") (Nothing,tbl)-md_table_opt :: (Bool,Bool,String) -> MD_Table String -> [String]-md_table_opt (pad_left,eq_width,col_sep) (hdr,t) =-    let c = transpose (T.make_regular "" (maybe t (:t) hdr))-        nc = length c-        n = let k = map (maximum . map length) c-            in if eq_width then replicate nc (maximum k) else k-        ext k s = if pad_left then T.pad_left ' ' k s else T.pad_right ' ' k s-        jn = intercalate col_sep-        m = jn (map (flip replicate '-') n)-        w = map jn (transpose (zipWith (map . ext) n c))-        d = map T.delete_trailing_whitespace w-    in case hdr of-         Nothing -> T.bracket (m,m) d-         Just _ -> case d of-                     [] -> error "md_table"-                     d0:d' -> d0 : T.bracket (m,m) d'--md_table' :: MD_Table String -> [String]-md_table' = md_table_opt (True,False," ")---- | '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 h = (map return "abc",map return "efgh")-> let t = md_matrix "" h (map (map show) [[1,2,3,4],[2,3,4,1],[3,4,1,2]])-->>> putStrLn $ unlines $ md_table' t-- - - - --  e f g h-a 1 2 3 4-b 2 3 4 1-c 3 4 1 2-- - - - ----}-md_matrix :: a -> ([a],[a]) -> [[a]] -> MD_Table a-md_matrix nil (r,c) t = md_table_join (Nothing,[nil] : map return r) (Nothing,c : t)---- | Variant that takes a 'show' function and a /header decoration/ function.-md_matrix_opt :: (a -> String) -> (String -> String) -> ([a],[a]) -> [[a]] -> MD_Table String-md_matrix_opt show_f hd_f nm t =-    let t' = map (map show_f) t-        nm' = T.bimap1 (map (hd_f . show_f)) nm-    in md_matrix "" nm' t'---- | MD embolden function.-md_embolden :: String -> String-md_embolden x = "__" ++ x ++ "__"---- | 'md_matrix_opt' with 'show' and markdown /bold/ annotations for header.--- the header cells are in bold.-md_matrix_bold :: Show a => ([a],[a]) -> [[a]] -> MD_Table String-md_matrix_bold = md_matrix_opt show md_embolden
+ Music/Theory/Array/Text.hs view
@@ -0,0 +1,123 @@+-- | Regular array data as plain text tables.+module Music.Theory.Array.Text where++import Data.List {- base -}++import qualified Data.List.Split as Split {- split -}++import qualified Music.Theory.Array as T {- hmt -}+import qualified Music.Theory.Function as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.String as T {- hmt -}++-- | Tabular text.+type TABLE = [[String]]++-- | Split table at indicated places.+--+-- > let tbl = [["1","2","3","4"],["A","B","E","F"],["C","D","G","H"]]+-- > table_split [2,2] tbl+table_split :: [Int] -> TABLE -> [TABLE]+table_split pl dat = transpose (map (Split.splitPlaces pl) dat)++-- | Join tables left to right.+--+-- > table_concat [[["1","2"],["A","B"],["C","D"]],[["3","4"],["E","F"],["G","H"]]]+table_concat :: [TABLE] -> TABLE+table_concat sq = map concat (transpose sq)++-- | Add a row number column at the front of the table.+--+-- > table_number_rows 0 tbl+table_number_rows :: Int -> TABLE -> TABLE+table_number_rows k dat = map (\(i,r) -> show i : r) (zip [k ..] dat)++{- | (HEADER,PAD-LEFT,EQ-WIDTH,COL-SEP,TBL-DELIM).++Options are:+ has header+ pad text with space to left instead of right,+ make all columns equal width,+ column separator string,+ print table delimiters+-}+type TABLE_OPT = (Bool,Bool,Bool,String,Bool)++-- | Options for @simple@ layout.+table_opt_simple :: TABLE_OPT+table_opt_simple = (True,True,False," ",True)++-- | Options for @pipe@ layout.+table_opt_pipe :: TABLE_OPT+table_opt_pipe = (True,True,False," | ",False)++-- | Pretty-print table.  Table is in row order.+--+-- > let tbl = [["1","2","3","4"],["a","bc","def"],["ghij","klm","no","p"]]+-- > putStrLn$unlines$"": table_pp (True,True,True," ",True) tbl+-- > putStrLn$unlines$"": table_pp (False,False,True," ",False) tbl+table_pp :: TABLE_OPT -> TABLE -> [String]+table_pp (has_hdr,pad_left,eq_width,col_sep,print_eot) dat =+    let c = transpose (T.tbl_make_regular_nil "" dat)+        nc = length c+        n = let k = map (maximum . map length) c+            in if eq_width then replicate nc (maximum k) else k+        ext k s = if pad_left then T.pad_left ' ' k s else T.pad_right ' ' k s+        jn = intercalate col_sep+        m = jn (map (flip replicate '-') n)+        w = map jn (transpose (zipWith (map . ext) n c))+        d = map T.delete_trailing_whitespace w+        pr x = if print_eot then T.bracket (m,m) x else x+    in case d of+         [] -> error "table_pp"+         d0:dr -> if has_hdr then d0 : pr dr else pr d++-- | Variant relying on 'Show' instances.+--+-- > table_pp_show table_opt_simple [[1..4],[5..8],[9..12]]+table_pp_show :: Show t => TABLE_OPT -> T.Table t -> [String]+table_pp_show opt = table_pp opt . map (map show)++-- | Variant in column order (ie. 'transpose').+--+-- > table_pp_column_order table_opt_simple [["a","bc","def"],["ghij","klm","no"]]+table_pp_column_order :: TABLE_OPT -> TABLE -> [String]+table_pp_column_order opt = table_pp opt . transpose++{- | Matrix form, ie. header in both first row and first column, in+each case displaced by one location which is empty.++> let h = (map return "abc",map return "efgh")+> let t = table_matrix h (map (map show) [[1,2,3,4],[2,3,4,1],[3,4,1,2]])++>>> putStrLn $ unlines $ table_pp table_opt_simple t+- - - - -+  e f g h+a 1 2 3 4+b 2 3 4 1+c 3 4 1 2+- - - - -++-}+table_matrix :: ([String],[String]) -> TABLE -> TABLE+table_matrix (r,c) t = table_concat [[""] : map return r,c : t]++-- | Variant that takes a 'show' function and a /header decoration/ function.+--+-- > table_matrix_opt show id ([1,2,3],[4,5,6]) [[7,8,9],[10,11,12],[13,14,15]]+table_matrix_opt :: (a -> String) -> (String -> String) -> ([a],[a]) -> T.Table a -> TABLE+table_matrix_opt show_f hd_f nm t =+    let nm' = T.bimap1 (map (hd_f . show_f)) nm+        t' = map (map show_f) t+    in table_matrix nm' t'++{-+-- | Two-tuple 'show' variant.+table_table_p2 :: (Show a,Show b) => TABLE_Opt -> Maybe [String] -> ([a],[b]) -> [String]+table_table_p2 opt hdr (p,q) = table_table' opt hdr [map show p,map show q]++-- | Three-tuple 'show' variant.+table_table_p3 :: (Show a,Show b,Show c) => TABLE_Opt -> Maybe [String] -> ([a],[b],[c]) -> [String]+table_table_p3 opt hdr (p,q,r) = table_table' opt hdr [map show p,map show q,map show r]++-}
Music/Theory/Byte.hs view
@@ -1,14 +1,73 @@ -- | Byte functions. module Music.Theory.Byte where -import qualified Data.ByteString as B {- bytestring -} import Data.Char {- base -}-import Data.List.Split {- split -} import Data.Maybe {- base -}+import Data.Word {- base -} import Numeric {- base -} +import qualified Data.ByteString as B {- bytestring -}+import qualified Data.List.Split as Split {- split -}+import qualified Safe {- safe -}++import qualified Music.Theory.Math.Convert as T {- hmt -} import qualified Music.Theory.Read as T {- hmt -} +{-+import Data.Int {- base -}+import qualified Data.ByteString.Lazy as L {- bytestring -}++-- * LBS++-- | Section function for 'L.ByteString', ie. from (n,m).+--+-- > lbs_slice 4 5 (L.pack [1..10]) == L.pack [5,6,7,8,9]+lbs_slice :: Int64 -> Int64 -> L.ByteString -> L.ByteString+lbs_slice n m = L.take m . L.drop n++-- | Variant of slice with start and end indices (zero-indexed).+--+-- > lbs_section 4 8 (L.pack [1..]) == L.pack [5,6,7,8,9]+lbs_section :: Int64 -> Int64 -> L.ByteString -> L.ByteString+lbs_section l r = L.take (r - l + 1) . L.drop l+-}++-- * Enumerations & Char++-- | 'toEnum' of 'T.word8_to_int'+word8_to_enum :: Enum e => Word8 -> e+word8_to_enum = toEnum . T.word8_to_int++-- | 'T.int_to_word8_maybe' of 'fromEnum'+enum_to_word8 :: Enum e => e -> Maybe Word8+enum_to_word8 = T.int_to_word8_maybe . fromEnum++-- | Type-specialised 'word8_to_enum'+--+-- > map word8_to_char [60,62] == "<>"+word8_to_char :: Word8 -> Char+word8_to_char = word8_to_enum++-- | 'T.int_to_word8' of 'fromEnum'+char_to_word8 :: Char -> Word8+char_to_word8 = T.int_to_word8 . fromEnum++-- | 'T.int_to_word8' of 'digitToInt'+digit_to_word8 :: Char -> Word8+digit_to_word8 = T.int_to_word8 . digitToInt++-- | 'intToDigit' of 'T.word8_to_int'+word8_to_digit :: Word8 -> Char+word8_to_digit = intToDigit . T.word8_to_int++-- * Indexing++-- | 'Safe.at' of 'T.word8_to_int'+word8_at :: [t] -> Word8 -> t+word8_at l = Safe.at l . T.word8_to_int++-- * Text+ -- | Given /n/ in (0,255) make two character hex string. -- -- > mapMaybe byte_hex_pp [0x0F,0xF0,0xF0F] == ["0F","F0"]@@ -23,33 +82,64 @@ byte_hex_pp_err :: (Integral i, Show i) => i -> String byte_hex_pp_err = fromMaybe (error "byte_hex_pp") . byte_hex_pp --- | 'unwords' of 'map' of 'byte_hex_pp_err'.+-- | 'byte_hex_pp_err' either plain (ws = False) or with spaces (ws = True).+--   Plain is the same format written by xxd -p and read by xxd -r -p. ----- > byte_seq_hex_pp [0x0F,0xF0] == "0F F0"-byte_seq_hex_pp :: (Integral i, Show i) => [i] -> String-byte_seq_hex_pp = unwords . map byte_hex_pp_err+-- > byte_seq_hex_pp True [0x0F,0xF0] == "0F F0"+byte_seq_hex_pp :: (Integral i, Show i) => Bool -> [i] -> String+byte_seq_hex_pp ws = (if ws then unwords else concat) . map byte_hex_pp_err  -- | Read two character hexadecimal string.-read_hex_byte :: (Eq t,Num t) => String -> t+--+-- > mapMaybe read_hex_byte (Split.chunksOf 2 "0FF0F") == [0x0F,0xF0]+read_hex_byte :: (Eq t,Num t) => String -> Maybe t read_hex_byte s =     case s of-      [_,_] -> T.reads_to_read_precise_err "readHex" readHex s-      _ -> error "read_hex_byte"+      [_,_] -> T.reads_to_read_precise readHex s+      _ -> Nothing +-- | Erroring variant.+read_hex_byte_err :: (Eq t,Num t) => String -> t+read_hex_byte_err = fromMaybe (error "read_hex_byte") . read_hex_byte++-- | Sequence of 'read_hex_byte_err'+--+-- > read_hex_byte_seq "000FF0FF" == [0x00,0x0F,0xF0,0xFF] read_hex_byte_seq :: (Eq t,Num t) => String -> [t]-read_hex_byte_seq = map read_hex_byte . words+read_hex_byte_seq = map read_hex_byte_err . Split.chunksOf 2 +-- | Variant that filters white space.+--+-- > read_hex_byte_seq_ws "00 0F F0 FF" == [0x00,0x0F,0xF0,0xFF]+read_hex_byte_seq_ws :: (Eq t,Num t) => String -> [t]+read_hex_byte_seq_ws = read_hex_byte_seq . filter (not . isSpace)++-- * IO+ -- | Load binary 'U8' sequence from file. load_byte_seq :: Integral i => FilePath -> IO [i] load_byte_seq = fmap (map fromIntegral . B.unpack) . B.readFile +-- | Store binary 'U8' sequence to file. store_byte_seq :: Integral i => FilePath -> [i] -> IO () store_byte_seq fn = B.writeFile fn . B.pack . map fromIntegral --- | Load hexadecimal text 'U8' sequence from file.-load_hex_byte_seq :: Integral i => FilePath -> IO [i]-load_hex_byte_seq = fmap (map read_hex_byte . words) . readFile+-- | Load hexadecimal text 'U8' sequences from file.+load_hex_byte_seq :: Integral i => FilePath -> IO [[i]]+load_hex_byte_seq = fmap (map read_hex_byte_seq . lines) . readFile --- | Store 'U8' sequence as hexadecimal text, 16 words per line.-store_hex_byte_seq :: (Integral i,Show i) => FilePath -> [i] -> IO ()-store_hex_byte_seq fn = writeFile fn . unlines . map unwords . chunksOf 16 . map byte_hex_pp_err+-- | Store 'U8' sequences as hexadecimal text, one sequence per line.+store_hex_byte_seq :: (Integral i,Show i) => FilePath -> [[i]] -> IO ()+store_hex_byte_seq fn = writeFile fn . unlines . map (byte_seq_hex_pp False)++{-++import qualified Data.ByteString.Base64 as Base64 {- base64-bytestring -}+let fn = "/home/rohan/sw/hsc3-data/data/yamaha/dx7/rom/ROM1A.syx"+b <- load_byte_seq fn :: IO [Word8]+let e = B.unpack (Base64.encode (B.pack b))+let r = B.unpack (Base64.decodeLenient (B.pack e))+(length b,length e,length r,b == r) == (4104,5472,4104,True)+map word8_to_char e++-}
Music/Theory/Combinations.hs view
@@ -5,7 +5,7 @@  -- | Number of /k/ element combinations of a set of /n/ elements. ----- > (nk_combinations 6 3,nk_combinations 13 3) == (20,286)+-- > map (uncurry nk_combinations) [(4,2),(5,3),(6,3),(13,3)] == [6,10,20,286] nk_combinations :: Integral a => a -> a -> a nk_combinations n k = T.nk_permutations n k `div` T.factorial k @@ -13,6 +13,7 @@ -- -- > combinations 3 [1..4] == [[1,2,3],[1,2,4],[1,3,4],[2,3,4]] -- > length (combinations 3 [1..5]) == nk_combinations 5 3+-- > combinations 3 "xyzw" == ["xyz","xyw","xzw","yzw"] combinations :: Int -> [a] -> [[a]] combinations k s =     case (k,s) of
Music/Theory/DB/Plain.hs view
@@ -47,7 +47,7 @@     in map (record_parse (fs,es)) r  db_sort :: [(Key,Int)] -> [Record] -> [Record]-db_sort k = T.sort_by_n_stage (map record_lookup_at k)+db_sort k = T.sort_by_n_stage_on (map record_lookup_at k)  db_load_utf8 :: SEP -> FilePath -> IO [Record] db_load_utf8 sep = fmap (db_parse sep) . IO.read_file_utf8
Music/Theory/Directory.hs view
@@ -5,8 +5,23 @@ import Data.Maybe {- base -} import System.Directory {- directory -} import System.FilePath {- filepath -}+import System.Process {- process -} +import qualified Music.Theory.Monad as T {- hmt -}++{- | 'takeDirectory' gives different answers depending on whether there is a trailing separator.++> x = ["x/y","x/y/","x","/"]+> map parent_dir x == ["x","x",".","/"]+> map takeDirectory x == ["x","x/y",".","/"]+-}+parent_dir :: FilePath -> FilePath+parent_dir = takeDirectory . dropTrailingPathSeparator+ -- | Scan a list of directories until a file is located, or not.+--   This does not traverse any sub-directory structure.+--+-- > mapM (path_scan ["/sbin","/usr/bin"]) ["fsck","ghc"] path_scan :: [FilePath] -> FilePath -> IO (Maybe FilePath) path_scan p fn =     case p of@@ -15,12 +30,63 @@                     f x = if x then return (Just nm) else path_scan p' fn                 in doesFileExist nm >>= f +-- | Erroring variant. path_scan_err :: [FilePath] -> FilePath -> IO FilePath path_scan_err p x =-    let err = (error ("path_scan: " ++ show p ++ ": " ++ x))+    let err = error (concat ["path_scan: ",show p,": ",x])     in fmap (fromMaybe err) (path_scan p x) +-- | Get list of files at dir with ext, ie. ls dir/*.ext+--+-- > dir_list_ext "/home/rohan/rd/j/" ".hs"+dir_list_ext :: FilePath -> String -> IO [FilePath]+dir_list_ext dir ext = do+  l <- listDirectory dir+  let fn = filter ((==) ext . takeExtension) l+  return (sort fn)++-- | Post-process 'dir_list_ext' to gives file-names with /dir/ prefix.+--+-- > dir_list_ext_path "/home/rohan/rd/j/" ".hs"+dir_list_ext_path :: FilePath -> String -> IO [FilePath]+dir_list_ext_path dir ext = dir_list_ext dir ext >>= return . map ((</>) dir)++-- | Find files having indicated filename.+--   This runs the system utility /find/, so is UNIX only.+--+-- > dir_find "DX7-ROM1A.syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+dir_find :: FilePath -> FilePath -> IO [FilePath]+dir_find fn dir = fmap lines (readProcess "find" [dir,"-name",fn] "")++-- | Require that exactly one file is located, else error.+--+-- > dir_find_1 "DX7-ROM1A.syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+dir_find_1 :: FilePath -> FilePath -> IO FilePath+dir_find_1 fn dir = do+  r <- dir_find fn dir+  case r of+    [x] -> return x+    _ -> error "dir_find_1?"++-- | Recursively find files having case-insensitive filename extension.+--   This runs the system utility /find/, so is UNIX only.+--+-- > dir_find_ext ".syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+dir_find_ext :: String -> FilePath -> IO [FilePath]+dir_find_ext ext dir = fmap lines (readProcess "find" [dir,"-iname",'*' : ext] "")++-- | Post-process 'dir_find_ext' to delete starting directory.+--+-- > dir_find_ext_rel ".syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+dir_find_ext_rel :: String -> FilePath -> IO [FilePath]+dir_find_ext_rel ext dir =+  let f = fromMaybe (error "dir_find_ext_rel?") . stripPrefix dir+  in fmap (map f) (dir_find_ext ext dir)+ -- | Subset of files in /dir/ with an extension in /ext/.+--   Extensions include the leading dot and are case-sensitive.+--+-- > dir_subset [".hs"] "/home/rohan/sw/hmt/cmd" dir_subset :: [String] -> FilePath -> IO [FilePath] dir_subset ext dir = do   let f nm = takeExtension nm `elem` ext@@ -36,3 +102,17 @@     then return x     else fmap (</> x) getCurrentDirectory +-- | If /i/ is an existing file then /j/ else /k/.+if_file_exists :: (FilePath,IO t,IO t) -> IO t+if_file_exists (i,j,k) = T.m_if (doesFileExist i,j,k)++-- | 'createDirectoryIfMissing' (including parents) and then 'writeFile'+writeFile_mkdir :: FilePath -> String -> IO ()+writeFile_mkdir fn s = do+  let dir = takeDirectory fn+  createDirectoryIfMissing True dir+  writeFile fn s++-- | 'writeFile_mkdir' only if file does not exist.+writeFile_mkdir_x :: FilePath -> String -> IO ()+writeFile_mkdir_x fn txt = if_file_exists (fn,return (),writeFile_mkdir fn txt)
Music/Theory/Duration.hs view
@@ -9,9 +9,12 @@ import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Ord as T {- hmt -} +type Division = Integer+type Dots = Int+ -- | Common music notation durational model-data Duration = Duration {division :: Integer -- ^ division of whole note-                         ,dots :: Integer -- ^ number of dots+data Duration = Duration {division :: Division -- ^ division of whole note+                         ,dots :: Int -- ^ number of dots                          ,multiplier :: Rational -- ^ tuplet modifier                          }                 deriving (Eq,Show)@@ -52,7 +55,7 @@ no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0  -- | Sum undotted divisions, input is required to be sorted.-sum_dur_undotted :: (Integer, Integer) -> Maybe Duration+sum_dur_undotted :: (Division, Division) -> Maybe Duration sum_dur_undotted (x0, x1)     | x0 == x1 = Just (Duration (x0 `div` 2) 0 1)     | x0 == x1 * 2 = Just (Duration x1 1 1)@@ -64,7 +67,7 @@ -- > sum_dur_dotted (4,0,2,1) == Just (Duration 1 0 1) -- > sum_dur_dotted (8,1,4,0) == Just (Duration 4 2 1) -- > sum_dur_dotted (16,0,4,2) == Just (Duration 2 0 1)-sum_dur_dotted :: (Integer,Integer,Integer,Integer) -> Maybe Duration+sum_dur_dotted :: (Division,Dots,Division,Dots) -> Maybe Duration sum_dur_dotted (x0, n0, x1, n1)     | x0 == x1 &&       n0 == 1 &&@@ -103,27 +106,27 @@     in fromMaybe err y2  -- | Standard divisions (from 0 to 256).  MusicXML allows @-1@ as a division (for @long@).-divisions_set :: [Integer]+divisions_set :: [Division] divisions_set = [0,1,2,4,8,16,32,64,128,256]  -- | Durations set derived from 'divisions_set' with up to /k/ dots.  Multiplier of @1@.-duration_set :: Integer -> [Duration]+duration_set :: Dots -> [Duration] duration_set k = [Duration dv dt 1 | dv <- divisions_set, dt <- [0..k]]  -- | Table of number of beams at notated division.-beam_count_tbl :: [(Integer,Integer)]+beam_count_tbl :: [(Division,Int)] beam_count_tbl = zip (-1 : divisions_set) [0,0,0,0,0,1,2,3,4,5,6]  -- | Lookup 'beam_count_tbl'. -- -- > whole_note_division_to_beam_count 32 == Just 3-whole_note_division_to_beam_count :: Integer -> Maybe Integer+whole_note_division_to_beam_count :: Division -> Maybe Int whole_note_division_to_beam_count x = lookup x beam_count_tbl  -- | Calculate number of beams at 'Duration'. -- -- > map duration_beam_count [Duration 2 0 1,Duration 16 0 1] == [0,2]-duration_beam_count :: Duration -> Integer+duration_beam_count :: Duration -> Int duration_beam_count (Duration x _ _) =     let err = error "duration_beam_count"         bc = whole_note_division_to_beam_count x@@ -132,7 +135,7 @@ -- * MusicXML  -- | Table giving @MusicXML@ types for divisions.-division_musicxml_tbl :: [(Integer,String)]+division_musicxml_tbl :: [(Division,String)] division_musicxml_tbl =     let nm = ["long","breve","whole","half","quarter","eighth"              ,"16th","32nd","64th","128th","256th"]@@ -141,7 +144,7 @@ -- | Lookup 'division_musicxml_tbl'. -- -- > map whole_note_division_to_musicxml_type [2,4] == ["half","quarter"]-whole_note_division_to_musicxml_type :: Integer -> String+whole_note_division_to_musicxml_type :: Division -> String whole_note_division_to_musicxml_type x =     T.lookup_err_msg "division_musicxml_tbl" x division_musicxml_tbl @@ -161,7 +164,7 @@ -- | Lookup 'division_unicode_tbl'. -- -- > map whole_note_division_to_unicode_symbol [1,2,4,8] == "𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮"-whole_note_division_to_unicode_symbol :: Integer -> Char+whole_note_division_to_unicode_symbol :: Division -> Char whole_note_division_to_unicode_symbol x =     T.lookup_err_msg "division_unicode_tbl" x division_unicode_tbl @@ -175,8 +178,8 @@  -- * Lilypond --- | Give /Lilypond/ notation for 'Duration'.  Note that the duration--- multiplier is /not/ written.+-- | Give /Lilypond/ notation for 'Duration'.+-- Note that the duration multiplier is /not/ written. -- -- > map duration_to_lilypond_type [Duration 2 0 1,Duration 4 1 1] == ["2","4."] duration_to_lilypond_type :: Duration -> String@@ -207,7 +210,7 @@  -- * Letter -whole_note_division_letter_pp :: Integer -> Maybe Char+whole_note_division_letter_pp :: Division -> Maybe Char whole_note_division_letter_pp x =     let t = [(16,'s'),(8,'e'),(4,'q'),(2,'h'),(1,'w')]     in lookup x t
Music/Theory/Duration/RQ.hs view
@@ -12,7 +12,7 @@ type RQ = Rational  -- > rq_duration_tbl 2-rq_duration_tbl :: Integer -> [(Rational,Duration)]+rq_duration_tbl :: Dots -> [(Rational,Duration)] rq_duration_tbl k = map (\d -> (duration_to_rq d,d)) (duration_set k)  -- | Rational quarter note to duration value.  It is a mistake to hope@@ -38,7 +38,7 @@ -- | Convert a whole note division integer to an 'RQ' value. -- -- > map whole_note_division_to_rq [1,2,4,8] == [4,2,1,1/2]-whole_note_division_to_rq :: Integer -> RQ+whole_note_division_to_rq :: Division -> RQ whole_note_division_to_rq x =     let f = (* 4) . recip . (%1)     in case x of@@ -48,8 +48,8 @@  -- | Apply dots to an 'RQ' duration. ----- > map (rq_apply_dots 1) [1,2] == [3/2,7/4]-rq_apply_dots :: RQ -> Integer -> RQ+-- > map (rq_apply_dots 1) [1,2] == [1 + 1/2,1 + 1/2 + 1/4]+rq_apply_dots :: RQ -> Dots -> RQ rq_apply_dots n d =     let m = iterate (/ 2) n     in sum (genericTake (d + 1) m)@@ -171,3 +171,23 @@                Nothing -> x                Just t -> map (rq_un_tuplet t) x     in all rq_is_cmn x'++-- * TIME++-- | Duration in seconds of RQ given ppm+--+--   ppm = pulses-per-minute, rq = rational-quarter-note+--+-- > map (\sd -> rq_to_seconds_ppm (90 * sd) 1) [1,2,4,8,16] == [2/3,1/3,1/6,1/12,1/24]+-- > map (rq_to_seconds_ppm 90) [1,2,3,4] == [2/3,1 + 1/3,2,2 + 2/3]+-- > map (rq_to_seconds_ppm 90) [0::RQ,1,1 + 1/2,1 + 3/4,1 + 7/8,2]+rq_to_seconds_ppm :: Fractional a => a -> a -> a+rq_to_seconds_ppm ppm rq = rq * (60 / ppm)++-- | PPM given that /rq/ has duration /x/, ie. inverse of 'rq_to_seconds'+--+-- > map (rq_to_ppm 1) [0.4,0.5,0.8,1,1.5,2] == [150,120,75,60,40,30]+-- > map (\ppm -> rq_to_seconds ppm 1) [150,120,75,60,40,30] == [0.4,0.5,0.8,1,1.5,2]+rq_to_ppm :: Fractional a => a -> a -> a+rq_to_ppm rq x = (rq / x) * 60+
Music/Theory/Dynamic_Mark.hs view
@@ -4,16 +4,26 @@ import Data.Char {- base -} import Data.List {- base -} import Data.Maybe {- base -}+import Text.Read {- base -} -import qualified Music.Theory.List as T+import qualified Music.Theory.List as T {- hmt -}  -- | Enumeration of dynamic mark symbols. data Dynamic_Mark_T = Niente                     | PPPPP | PPPP | PPP | PP | P | MP                     | MF | F | FF | FFF | FFFF | FFFFF                     | FP | SF | SFP | SFPP | SFZ | SFFZ-                      deriving (Eq,Ord,Enum,Bounded,Show)+                      deriving (Eq,Ord,Enum,Bounded,Show,Read) +-- | Case insensitive reader for 'Dynamic_Mark_T'.+--+-- > map dynamic_mark_t_parse (words "pP p Mp F")+dynamic_mark_t_parse_ci :: String -> Maybe Dynamic_Mark_T+dynamic_mark_t_parse_ci s =+  case map toUpper s of+    "NIENTE" -> Just Niente+    uc -> readMaybe uc+ -- | Lookup MIDI velocity for 'Dynamic_Mark_T'.  The range is linear -- in @0-127@. --@@ -150,8 +160,7 @@ -- -- > let f _ x = show x -- > in apply_dynamic_node f f (Nothing,Just Crescendo) undefined-apply_dynamic_node :: (a -> Dynamic_Mark_T -> a) -> (a -> Hairpin_T -> a)-                   -> Dynamic_Node -> a -> a+apply_dynamic_node :: (a -> Dynamic_Mark_T -> a) -> (a -> Hairpin_T -> a) -> Dynamic_Node -> a -> a apply_dynamic_node f g (i,j) m =     let n = maybe m (g m) j     in maybe n (f n) i
Music/Theory/Either.hs view
@@ -1,16 +1,28 @@ -- | Either module Music.Theory.Either where +import Data.Maybe {- base -}+ -- | Maybe 'Left' of 'Either'.-fromLeft :: Either a b -> Maybe a-fromLeft e =+from_left :: Either a b -> Maybe a+from_left e =     case e of       Left x -> Just x       _ -> Nothing +from_left_err :: Either t e -> t+from_left_err = fromMaybe (error "from_left_err") . from_left+ -- | Maybe 'Right' of 'Either'.-fromRight :: Either a b -> Maybe b-fromRight e =+from_right :: Either x t -> Maybe t+from_right e =     case e of-      Right x -> Just x-      _ -> Nothing+      Left _ -> Nothing+      Right r -> Just r++from_right_err :: Either e t -> t+from_right_err = fromMaybe (error "from_right_err") . from_right++-- | Flip from right to left, ie. 'either' 'Right' 'Left'+either_swap :: Either a b -> Either b a+either_swap = either Right Left
Music/Theory/Function.hs view
@@ -1,6 +1,21 @@ -- | "Data.Function" related functions. module Music.Theory.Function where +import Data.Function {- base -}++-- | Unary operator.+type UOp t = t -> t++-- | Binary operator.+type BinOp t = t -> t -> t++-- | Iterate the function /f/ /n/ times, the inital value is /x/.+--+-- > recur_n 5 (* 2) 1 == 32+-- > take (5 + 1) (iterate (* 2) 1) == [1,2,4,8,16,32]+recur_n :: Integral n => n -> (t -> t) -> t -> t+recur_n n f x = if n < 1 then x else recur_n (n - 1) f (f x)+ -- | 'const' of 'const'. -- -- > const2 5 undefined undefined == 5@@ -10,16 +25,17 @@  -- * Predicate composition. --- | '&&' of predicates.+-- | '&&' of predicates, ie. do predicates /f/ and /g/ both hold at /x/. predicate_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool predicate_and f g x = f x && g x --- | 'all' of predicates.+-- | List variant of 'predicate_and', ie. 'foldr1' -- -- > let r = [False,False,True,False,True,False]--- > in map (predicate_all [(> 0),(< 5),even]) [0..5] == r+-- > map (predicate_all [(> 0),(< 5),even]) [0..5] == r predicate_all :: [t -> Bool] -> t -> Bool-predicate_all p x = all id (map ($ x) p)+predicate_all = foldr1 predicate_and+--predicate_all p x = all id (map ($ x) p)  -- | '||' of predicates. predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool@@ -28,10 +44,14 @@ -- | 'any' of predicates, ie. logical /or/ of list of predicates. -- -- > let r = [True,False,True,False,True,True]--- > in map (predicate_any [(== 0),(== 5),even]) [0..5] == r+-- > map (predicate_any [(== 0),(== 5),even]) [0..5] == r predicate_any :: [t -> Bool] -> t -> Bool predicate_any p x = any id (map ($ x) p) +-- | '==' 'on'.+eq_on :: Eq t => (u -> t) -> u -> u -> Bool+eq_on f = (==) `on` f+ -- * Function composition.  -- . is infixr 9, this allows f . g .: h@@ -57,3 +77,8 @@ (.:::::) :: (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 . (.::::) +-- * 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)
Music/Theory/Gamelan.hs view
@@ -26,6 +26,7 @@ -- | Enumeration of gamelan instrument families. data Instrument_Family     = Bonang+    | Gambang     | Gender     | Gong     | Saron@@ -39,6 +40,7 @@ data Instrument_Name     = Bonang_Barung -- ^ Bonang Barung (horizontal gong, middle)     | Bonang_Panerus -- ^ Bonang Panerus (horizontal gong, high)+    | Gambang_Kayu -- ^ Gambang Kayu (wooden key&resonator)     | Gender_Barung -- ^ Gender Barung (key&resonator, middle)     | Gender_Panerus -- ^ Gender Panembung (key&resonator, high)     | Gender_Panembung -- ^ Gender Panembung, Slenthem (key&resonator, low)@@ -47,29 +49,30 @@     | Kempul -- ^ Kempul (hanging gong, middle)     | Kempyang -- ^ Kempyang (horizontal gong, high)     | Kenong -- ^ Kenong (horizontal gong, low)-    | Ketuk -- ^ Ketuk (horizontal gong, middle)+    | Ketuk -- ^ Ketuk, Kethuk (horizontal gong, middle)     | Saron_Barung -- ^ Saron Barung, Saron (key, middle)     | Saron_Demung -- ^ Saron Demung, Demung (key, low)     | Saron_Panerus -- ^ Saron Panerus, Peking (key, high)       deriving (Enum,Bounded,Eq,Ord,Show,Read) -instrument_family :: Instrument_Name -> Maybe Instrument_Family+instrument_family :: Instrument_Name -> Instrument_Family instrument_family nm =     case nm of-      Bonang_Barung -> Just Bonang-      Bonang_Panerus -> Just Bonang-      Gender_Barung -> Just Gender-      Gender_Panerus -> Just Gender-      Gender_Panembung -> Just Gender-      Gong_Ageng -> Just Gong-      Gong_Suwukan -> Just Gong-      Kempul -> Just Gong-      Kempyang -> Nothing-      Kenong -> Nothing-      Ketuk -> Nothing-      Saron_Barung -> Just Saron-      Saron_Demung -> Just Saron-      Saron_Panerus -> Just Saron+      Bonang_Barung -> Bonang+      Bonang_Panerus -> Bonang+      Gambang_Kayu -> Gambang+      Gender_Barung -> Gender+      Gender_Panerus -> Gender+      Gender_Panembung -> Gender+      Gong_Ageng -> Gong+      Gong_Suwukan -> Gong+      Kempul -> Gong+      Kempyang -> Gong+      Kenong -> Gong+      Ketuk -> Gong+      Saron_Barung -> Saron+      Saron_Demung -> Saron+      Saron_Panerus -> Saron  instrument_name_pp :: Instrument_Name -> String instrument_name_pp =@@ -82,6 +85,7 @@     case nm of       Bonang_Barung -> T.Clef T.Treble 0       Bonang_Panerus -> T.Clef T.Treble 1+      Gambang_Kayu -> T.Clef T.Treble 0       Gender_Barung -> T.Clef T.Treble 0       Gender_Panerus -> T.Clef T.Treble 1       Gender_Panembung -> T.Clef T.Bass 0@@ -101,15 +105,26 @@ -- | Enumeration of Gamelan scales. data Scale = Pelog | Slendro deriving (Enum,Eq,Ord,Show,Read) +-- | Octaves are zero-indexed and may be negative. type Octave = Integer++-- | Degrees are one-indexed. type Degree = Integer++-- | Frequency in hertz. type Frequency = Double++-- | A text annotation. type Annotation = String +-- | 'Octave' and 'Degree'. data Pitch = Pitch {pitch_octave :: Octave                    ,pitch_degree :: Degree}              deriving (Eq,Ord,Show) +-- | Octaves are written as repeated @-@ or @+@, degrees are printed ordinarily.+--+-- > map pitch_pp_ascii (zipWith Pitch [-2 .. 2] [1 .. 5]) == ["--1","-2","3","+4","++5"] pitch_pp_ascii :: Pitch -> String pitch_pp_ascii (Pitch o d) =     let d' = intToDigit (fromIntegral d)@@ -121,97 +136,121 @@ pitch_pp_duple :: Pitch -> String pitch_pp_duple (Pitch o d) = printf "(%d,%d)" o d +-- | 'Scale' and 'Pitch'. data Note = Note {note_scale :: Scale                  ,note_pitch :: Pitch}-             deriving (Eq,Ord,Show)+             deriving (Eq,Show) +-- | 'pitch_degree' of 'note_pitch'. note_degree :: Note -> Degree note_degree = pitch_degree . note_pitch -data Tone = Tone {tone_instrument_name :: Instrument_Name-                 ,tone_note :: Maybe Note-                 ,tone_frequency :: Maybe Frequency-                 ,tone_annotation :: Maybe Annotation}-             deriving (Eq,Show)+-- | It is an error to compare notes from different scales.+note_compare :: Note -> Note -> Ordering+note_compare (Note s1 p1) (Note s2 p2) =+  if s1 /= s2+  then error "note_compare?"+  else compare p1 p2 -tone_frequency_err :: Tone -> Frequency+-- | Orderable if scales are equal.+instance Ord Note where compare = note_compare++-- | Ascending sequence of 'Note' for 'Scale' from /p1/ to /p2/ inclusive.+note_range_elem :: Scale -> Pitch -> Pitch -> [Note]+note_range_elem scl p1@(Pitch o1 _d1) p2@(Pitch o2 _d2) =+  let univ = [Note scl (Pitch o d) | o <- [o1 .. o2], d <- scale_degrees scl]+  in filter (\n -> note_pitch n >= p1 && note_pitch n <= p2) univ++-- | Ascending sequence of 'Note' from /n1/ to /n2/ inclusive.+--+-- > note_gamut_elem (Note Slendro (Pitch 0 5)) (Note Slendro (Pitch 1 2))+note_gamut_elem :: Note -> Note -> [Note]+note_gamut_elem (Note s1 p1) (Note s2 p2) =+  if s1 /= s2+  then error "note_gamut_elem?"+  else note_range_elem s1 p1 p2++data Tone t = Tone {tone_instrument_name :: Instrument_Name+                   ,tone_note :: Maybe Note+                   ,tone_frequency :: Maybe Frequency+                   ,tone_annotation :: Maybe t}+              deriving (Eq,Show)++tone_frequency_err :: Tone t -> Frequency tone_frequency_err = fromJust_err "tone_frequency" . tone_frequency  -- | Orderable if frequency is given.-instance Ord Tone where compare = tone_compare_frequency+instance Eq t => Ord (Tone t) where compare = tone_compare_frequency  -- | Constructor for 'Tone' without /frequency/ or /annotation/.-plain_tone :: Instrument_Name -> Scale -> Octave -> Degree -> Tone+plain_tone :: Instrument_Name -> Scale -> Octave -> Degree -> Tone t plain_tone nm sc o d = Tone nm (Just (Note sc (Pitch o d))) Nothing Nothing  -- | Tones are considered /equivalent/ if they have the same -- 'Instrument_Name' and 'Note'.-tone_equivalent :: Tone -> Tone -> Bool+tone_equivalent :: Tone t -> Tone t -> Bool tone_equivalent p q =     let Tone nm nt _ _ = p         Tone nm' nt' _ _ = q     in nm == nm' && nt == nt' -tone_24et_pitch :: Tone -> Maybe T.Pitch+tone_24et_pitch :: Tone t -> Maybe T.Pitch tone_24et_pitch =     let f i = let (_,pt,_,_,_) = T.nearest_24et_tone i in pt     in fmap f . tone_frequency -tone_24et_pitch' :: Tone -> T.Pitch+tone_24et_pitch' :: Tone t -> T.Pitch tone_24et_pitch' = fromJust_err "tone_24et_pitch" . tone_24et_pitch -tone_24et_pitch_detune :: Tone -> Maybe T.Pitch_Detune+tone_24et_pitch_detune :: Tone t -> Maybe T.Pitch_Detune tone_24et_pitch_detune = fmap T.nearest_pitch_detune_24et . tone_frequency -tone_24et_pitch_detune' :: Tone -> T.Pitch_Detune+tone_24et_pitch_detune' :: Tone t -> T.Pitch_Detune tone_24et_pitch_detune' = fromJust_err "tone_24et_pitch_detune" . tone_24et_pitch_detune -tone_fmidi :: Tone -> Double+tone_fmidi :: Tone t -> Double tone_fmidi = T.cps_to_fmidi . tone_frequency_err  -- | Fractional (rational) 24-et midi note number of 'Tone'.-tone_24et_fmidi :: Tone -> Rational+tone_24et_fmidi :: Tone t -> Rational tone_24et_fmidi = near_rat . T.pitch_to_fmidi . tone_24et_pitch' -tone_12et_pitch :: Tone -> Maybe T.Pitch+tone_12et_pitch :: Tone t -> Maybe T.Pitch tone_12et_pitch =     let f i = let (_,pt,_,_,_) = T.nearest_12et_tone i in pt     in fmap f . tone_frequency -tone_12et_pitch' :: Tone -> T.Pitch+tone_12et_pitch' :: Tone t -> T.Pitch tone_12et_pitch' = fromJust_err "tone_12et_pitch" . tone_12et_pitch -tone_12et_pitch_detune :: Tone -> Maybe T.Pitch_Detune+tone_12et_pitch_detune :: Tone t -> Maybe T.Pitch_Detune tone_12et_pitch_detune = fmap T.nearest_pitch_detune_12et . tone_frequency -tone_12et_pitch_detune' :: Tone -> T.Pitch_Detune+tone_12et_pitch_detune' :: Tone t -> T.Pitch_Detune tone_12et_pitch_detune' = fromJust_err "tone_12et_pitch_detune" . tone_12et_pitch_detune  -- | Fractional (rational) 24-et midi note number of 'Tone'.-tone_12et_fmidi :: Tone -> Rational+tone_12et_fmidi :: Tone t -> Rational tone_12et_fmidi = near_rat . T.pitch_to_fmidi . tone_12et_pitch' -tone_family :: Tone -> Maybe Instrument_Family+tone_family :: Tone t -> Instrument_Family tone_family = instrument_family . tone_instrument_name -tone_family_err :: Tone -> Instrument_Family-tone_family_err = fromJust_err "tone_family" . tone_family--tone_in_family :: Instrument_Family -> Tone -> Bool-tone_in_family c t = tone_family t == Just c+tone_in_family :: Instrument_Family -> Tone t -> Bool+tone_in_family c t = tone_family t == c -select_tones :: Instrument_Family -> [Tone] -> [Maybe Tone]+select_tones :: Instrument_Family -> [Tone t] -> [Maybe (Tone t)] select_tones c =-    let f t = if tone_family t == Just c then Just t else Nothing+    let f t = if tone_family t == c then Just t else Nothing     in map f  -- | Specify subset as list of families and scales. type Tone_Subset = ([Instrument_Family],[Scale])  -- | Extract subset of 'Tone_Set'.-tone_subset :: Tone_Subset -> Tone_Set -> Tone_Set+tone_subset :: Tone_Subset -> Tone_Set t -> Tone_Set t tone_subset (fm,sc) =-    let f t = fromJust_err "tone_subset" (tone_family t) `elem` fm &&+    let f t = tone_family t `elem` fm &&               fromJust_err "tone_subset" (tone_scale t) `elem` sc     in filter f @@ -221,43 +260,43 @@                              ,instrument_frequencies :: Maybe [Frequency]}                   deriving (Eq,Show) -type Tone_Set = [Tone]-type Tone_Group = [Tone_Set]+type Tone_Set t = [Tone t]+type Tone_Group t = [Tone_Set t] type Gamelan = [Instrument] -tone_scale :: Tone -> Maybe Scale+tone_scale :: Tone t -> Maybe Scale tone_scale = fmap note_scale . tone_note -tone_pitch :: Tone -> Maybe Pitch+tone_pitch :: Tone t -> Maybe Pitch tone_pitch = fmap note_pitch . tone_note -tone_degree :: Tone -> Maybe Degree+tone_degree :: Tone t -> Maybe Degree tone_degree = fmap pitch_degree . tone_pitch -tone_degree' :: Tone -> Degree+tone_degree' :: Tone t -> Degree tone_degree' = fromJust_err "tone_degree" . tone_degree -tone_octave :: Tone -> Maybe Octave+tone_octave :: Tone t -> Maybe Octave tone_octave = fmap pitch_octave . tone_pitch -tone_class :: Tone -> (Instrument_Name,Maybe Scale)+tone_class :: Tone t -> (Instrument_Name,Maybe Scale) tone_class t = (tone_instrument_name t,tone_scale t)  instrument_class :: Instrument -> (Instrument_Name,Maybe Scale) instrument_class i = (instrument_name i,instrument_scale i) -tone_class_p :: (Instrument_Name, Scale) -> Tone -> Bool+tone_class_p :: (Instrument_Name, Scale) -> Tone t -> Bool tone_class_p (nm,sc) t =     tone_instrument_name t == nm &&     tone_scale t == Just sc -tone_family_class_p :: (Instrument_Family,Scale) -> Tone -> Bool+tone_family_class_p :: (Instrument_Family,Scale) -> Tone t -> Bool tone_family_class_p (fm,sc) t =-    instrument_family (tone_instrument_name t) == Just fm &&+    instrument_family (tone_instrument_name t) == fm &&     tone_scale t == Just sc  -- | Given a 'Tone_Set', find those 'Tone's that are within 'T.Cents' of 'Frequency'.-tone_set_near_frequency :: Tone_Set -> T.Cents -> Frequency -> Tone_Set+tone_set_near_frequency :: Tone_Set t -> T.Cents -> Frequency -> Tone_Set t tone_set_near_frequency t k n =     let near i = abs (T.cps_difference_cents i n) <= k         near_t i = maybe False near (tone_frequency i)@@ -265,7 +304,7 @@  -- | Compare 'Tone's by frequency.  'Tone's without frequency compare -- as if at frequency @0@.-tone_compare_frequency :: Tone -> Tone -> Ordering+tone_compare_frequency :: Tone t -> Tone t -> Ordering tone_compare_frequency = compare `on` (maybe 0 id . tone_frequency)  -- | If all /f/ of /a/ are 'Just' /b/, then 'Just' /[b]/, else@@ -275,7 +314,7 @@     let x' = map f x     in if any isNothing x' then Nothing else Just (catMaybes x') -instrument :: Tone_Set -> Instrument+instrument :: Tone_Set t -> Instrument instrument c =     let sf = fmap note_scale . tone_note         pf = fmap note_pitch . tone_note@@ -289,7 +328,7 @@          t:_ -> Instrument (tone_instrument_name t) (sf t) p f          [] -> undefined -instruments :: Tone_Set -> [Instrument]+instruments :: Tone_Set t -> [Instrument] instruments c =     let c' = sortBy (compare `on` tone_instrument_name) c         c'' = groupBy ((==) `on` tone_class) c'@@ -300,12 +339,18 @@     let f p = (head p,last p)     in fmap f . instrument_pitches +-- | Pelog has seven degrees, numbered one to seven.+--   Slendro has five degrees, numbered one to six excluding four.+--+-- > map scale_degrees [Pelog,Slendro] == [[1,2,3,4,5,6,7],[1,2,3,5,6]] scale_degrees :: Scale -> [Degree] scale_degrees s =     case s of       Pelog -> [1..7]       Slendro -> [1,2,3,5,6] +-- | Zero based index of scale degree, or Nothing.+-- -- > degree_index Slendro 4 == Nothing -- > degree_index Pelog 4 == Just 3 degree_index :: Scale -> Degree -> Maybe Int@@ -313,13 +358,13 @@  -- * Tone set -tone_set_gamut :: Tone_Set -> Maybe (Pitch,Pitch)+tone_set_gamut :: Tone_Set t -> Maybe (Pitch,Pitch) tone_set_gamut g =     case mapMaybe (fmap note_pitch . tone_note) g of       [] -> Nothing       p -> Just (minimum p,maximum p) -tone_set_instrument :: Tone_Set -> (Instrument_Name,Maybe Scale) -> Tone_Set+tone_set_instrument :: Tone_Set t -> (Instrument_Name,Maybe Scale) -> Tone_Set t tone_set_instrument db (i,s) =     let f t = tone_class t == (i,s)     in filter f db
Music/Theory/Graph/Deacon_1934.hs view
@@ -16,15 +16,15 @@ import qualified Music.Theory.Tuple as T {- hmt -}  gen_graph :: Ord v => [T.DOT_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]-gen_graph opt pp es = T.g_to_udot opt pp (T.g_from_edges_l es)+gen_graph opt pp es = T.fgl_to_udot opt pp (T.g_from_edges_l es)  gen_graph_ul :: Ord v => [T.DOT_ATTR] -> (v -> String) -> [T.EDGE v] -> [String]-gen_graph_ul opt pp es = T.g_to_udot opt (T.gr_pp_lift_node_f pp) (T.g_from_edges es)+gen_graph_ul opt pp es = T.fgl_to_udot opt (T.gr_pp_label_v pp) (T.g_from_edges es)  gen_digraph :: Ord v => [T.DOT_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]-gen_digraph opt pp es = T.g_to_dot T.G_DIGRAPH opt pp Nothing (T.g_from_edges_l es)+gen_digraph opt pp es = T.fgl_to_dot T.G_DIGRAPH opt pp (T.g_from_edges_l es) -type G = (T.GRAPH String,[T.DOT_ATTR],FilePath)+type G = ([T.EDGE String],[T.DOT_ATTR],FilePath)  -- * E g1 :: G@@ -118,10 +118,10 @@   let mk_nm ty = "/home/rohan/sw/hmt/data/dot/deacon/" ++ nm ++ "_" ++ ty ++ ".dot"       wr_f ty g = writeFile (mk_nm ty) (unlines g)   wr_f "G" (gen_graph_ul o id e)-  wr_f "GL" (gen_graph o T.gr_pp_id_show (T.e_label_seq e))-  wr_f "GC" (gen_graph o T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e)))+  wr_f "GL" (gen_graph o (T.gr_pp_label id show) (T.e_label_seq e))+  wr_f "GC" (gen_graph o (T.gr_pp_label id T.br_csl_pp) (T.e_collate_normalised_l (T.e_label_seq e)))   wr_f "GF" (gen_graph_ul o id (nub (map T.t2_sort e)))-  wr_f "GD" (gen_digraph o T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e)))+  wr_f "GD" (gen_digraph o (T.gr_pp_label id T.br_csl_pp) (T.e_collate_normalised_l (T.e_label_seq e))) {-   let o' = ("graph:layout","fdp") : o   wr_f "GC_" (gen_graph o' T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e)))
Music/Theory/Graph/Dot.hs view
@@ -1,97 +1,137 @@ -- | Graph (dot) functions. module Music.Theory.Graph.Dot where +import Control.Monad {- base -} import Data.Char {- base -} import Data.List {- base -}+import System.FilePath {- filepath -}+import System.Process {- process -}  import qualified Data.Graph.Inductive.Graph as G {- fgl -}-import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -} -import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Graph.FGL as T {- hmt -}+import qualified Music.Theory.Graph.Type as T {- hmt -}+import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Show as Show {- hmt -}  -- * UTIL --- | Separate at element.+-- | Classify /s/ using a first element predicate, a remainder predicate and a unit predicate.+s_classify :: (t -> Bool) -> (t -> Bool) -> ([t] -> Bool) -> [t] -> Bool+s_classify p q r s =+  case s of+    c0:s' -> p c0 && all q s' && r s+    [] -> False++-- | Symbol rule. ----- > sep1 ':' "graph:layout"-sep1 :: Eq t => t -> [t] -> ([t],[t])-sep1 e l =-    case break (== e) l of-      (p,_:q) -> (p,q)-      _ -> error "sep1"+-- > map is_symbol ["sym","Sym2","3sym","1",""] == [True,True,False,False,False]+is_symbol :: String -> Bool+is_symbol = s_classify isAlpha isAlphaNum (const True) --- | Quote /s/ if it includes white space.+-- | Number rule. ----- > map maybe_quote ["abc","a b c"] == ["abc","\"a b c\""]-maybe_quote :: String -> String-maybe_quote s = if any isSpace s then concat ["\"",s,"\""] else s+-- > map is_number ["123","123.45",".25","1.","1.2.3",""] == [True,True,False,True,False,False]+is_number :: String -> Bool+is_number = s_classify isDigit (\c -> isDigit c || c == '.') ((< 2) . length . filter ((==) '.')) --- | Left biased union of association lists /p/ and /q/.+-- | Quote /s/ if 'is_symbol' or 'is_number'. ----- > assoc_union [(5,"a"),(3,"b")] [(5,"A"),(7,"C")] == [(5,"a"),(3,"b"),(7,"C")]-assoc_union :: Eq k => [(k,v)] -> [(k,v)] -> [(k,v)]-assoc_union p q =-    let p_k = map fst p-        q' = filter ((`notElem` p_k) . fst) q-    in p ++ q'+-- > map maybe_quote ["abc","a b c","12","12.3"] == ["abc","\"a b c\"","12","12.3"]+maybe_quote :: String -> String+maybe_quote s = if is_symbol s || is_number s then s else concat ["\"",s,"\""] --- * ATTR+-- * ATTR/KEY --- | area:opt (area = graph|node|edge) type DOT_KEY = String-type DOT_OPT = String type DOT_VALUE = String-type DOT_ATTR = (DOT_OPT,DOT_VALUE)-type DOT_ATTR_SET = (String,[DOT_ATTR])---- > dot_key_sep "graph:layout"-dot_key_sep :: String -> (String,String)-dot_key_sep = sep1 ':'+type DOT_ATTR = (DOT_KEY,DOT_VALUE) +-- | Format 'DOT_ATTR'. dot_attr_pp :: DOT_ATTR -> String dot_attr_pp (lhs,rhs) = concat [lhs,"=",maybe_quote rhs] +-- | Format sequence of DOT_ATTR.+--+-- > dot_attr_seq_pp [("layout","neato"),("epsilon","0.0001")]+dot_attr_seq_pp :: [DOT_ATTR] -> String+dot_attr_seq_pp opt =+  if null opt+  then ""+  else concat ["[",intercalate "," (map dot_attr_pp opt),"]"]++-- | Merge attributes, left-biased.+dot_attr_ext :: [DOT_ATTR] -> [DOT_ATTR] -> [DOT_ATTR]+dot_attr_ext = List.assoc_merge++-- | graph|node|edge+type DOT_TYPE = String++-- | (type,[attr])+type DOT_ATTR_SET = (DOT_TYPE,[DOT_ATTR])++-- | Format DOT_ATTR_SET.+--+-- > a = ("graph",[("layout","neato"),("epsilon","0.0001")])+-- > dot_attr_set_pp a == "graph [layout=neato,epsilon=0.0001]" dot_attr_set_pp :: DOT_ATTR_SET -> String-dot_attr_set_pp (ty,opt) = concat [ty," [",intercalate "," (map dot_attr_pp opt),"];"]+dot_attr_set_pp (ty,opt) = concat [ty," ",dot_attr_seq_pp opt] -dot_attr_collate :: [DOT_ATTR] -> [DOT_ATTR_SET]+-- | type:attr (type = graph|node|edge)+type DOT_META_KEY = String++type DOT_META_ATTR = (DOT_META_KEY,DOT_VALUE)++-- | Keys are given as "type:attr".+--+-- > dot_key_sep "graph:layout" == ("graph","layout")+dot_key_sep :: DOT_META_KEY -> (DOT_TYPE,DOT_KEY)+dot_key_sep = List.split_on_1_err ":"++-- | Collate DOT_KEY attribute set to DOT_ATTR_SET.+dot_attr_collate :: [DOT_META_ATTR] -> [DOT_ATTR_SET] dot_attr_collate opt =     let f (k,v) = let (ty,nm) = dot_key_sep k in (ty,(nm,v))         c = map f opt-    in T.collate c--dot_attr_ext :: [DOT_ATTR] -> [DOT_ATTR] -> [DOT_ATTR]-dot_attr_ext = assoc_union+    in List.collate c --- > map dot_attr_set_pp (dot_attr_collate dot_attr_def)-dot_attr_def :: [DOT_ATTR]-dot_attr_def =-    [("graph:layout","neato")-    ,("graph:epsilon","0.000001")-    ,("node:shape","plaintext")-    ,("node:fontsize","10")-    ,("node:fontname","century schoolbook")]+-- | Default values for default meta-keys.+--+-- > k = dot_attr_def ("neato","century schoolbook",10,"plaintext")+-- > map dot_attr_set_pp (dot_attr_collate k)+dot_attr_def :: (String,String,Double,String) -> [(DOT_META_ATTR)]+dot_attr_def (ly,fn,fs,sh) =+    [("graph:layout",ly)+    ,("node:fontname",fn)+    ,("node:fontsize",show fs)+    ,("node:shape",sh)]  -- * GRAPH --- | Graph pretty-printer, (node->shape,node->label,edge->label)-type GR_PP v e = (v -> Maybe String,v -> Maybe String,e -> Maybe String)+-- | Graph pretty-printer, (v -> [attr],e -> [attr])+type GR_PP v e = ((Int,v) -> [DOT_ATTR],((Int,Int),e) -> [DOT_ATTR]) -gr_pp_lift_node_f :: (v -> String) -> GR_PP v e-gr_pp_lift_node_f f = (const Nothing, Just . f, const Nothing)+gr_pp_label_m :: Maybe (v -> DOT_VALUE) -> Maybe (e -> DOT_VALUE) -> GR_PP v e+gr_pp_label_m f_v f_e =+  let lift m (_,x) = case m of+                       Nothing -> []+                       Just f -> [("label",f x)]+  in (lift f_v,lift f_e) -gr_pp_id_show :: Show e => GR_PP String e-gr_pp_id_show = (const Nothing,Just . id,Just . show)+-- | Label V & E.+gr_pp_label :: (v -> DOT_VALUE) -> (e -> DOT_VALUE) -> GR_PP v e+gr_pp_label f_v f_e = gr_pp_label_m (Just f_v) (Just f_e) +-- | Label V only.+gr_pp_label_v :: (v -> DOT_VALUE) -> GR_PP v e+gr_pp_label_v f = gr_pp_label_m (Just f) Nothing+ -- | br = brace, csl = comma separated list br_csl_pp :: Show t => [t] -> String br_csl_pp l =     case l of       [e] -> show e-      _ -> T.bracket ('{','}') (intercalate "," (map show l))--gr_pp_id_br_csl :: Show e => GR_PP String [e]-gr_pp_id_br_csl = (const Nothing,Just . id,Just . br_csl_pp)+      _ -> List.bracket ('{','}') (intercalate "," (map show l))  -- | Graph type, directed or un-directed. data G_TYPE = G_DIGRAPH | G_UGRAPH@@ -108,24 +148,62 @@       G_DIGRAPH -> " -> "       G_UGRAPH -> " -- " +node_pos_attr :: (Show n, Real n) => (n,n) -> DOT_ATTR+node_pos_attr (x,y) = let pp = Show.real_pp_trunc 2 in ("pos",concat [pp x,",",pp y])++-- | Edge POS attributes are sets of cubic bezier control points.+edge_pos_attr :: Real t => [(t,t)] -> DOT_ATTR+edge_pos_attr pt =+  let r_pp = Show.real_pp_trunc 2+      pt_pp (x,y) = concat [r_pp x,",",r_pp y]+  in ("pos",unwords (map pt_pp pt))++-- | Variant that accepts single cubic bezier data set.+edge_pos_attr_1 :: Real t => ((t,t),(t,t),(t,t),(t,t)) -> DOT_ATTR+edge_pos_attr_1 (p1,p2,p3,p4) = edge_pos_attr [p1,p2,p3,p4]++{- -- | Vertex position function. type POS_FN v = (v -> (Int,Int)) -g_to_dot :: G_TYPE -> [DOT_ATTR] -> GR_PP v e -> Maybe (POS_FN v) -> G.Gr v e -> [String]-g_to_dot g_typ opt (n_sh,n_pp,e_pp) pos_f gr =-    let p_f (c,r) = concat [",pos=\"",show (c * 100),",",show (r * 100),"\""]-        l_f p x = concat [" [label=\"",x,"\"",p,"]"]-        n_f (k,n) = let p = maybe "" (\f -> p_f (f n)) pos_f-                        p' = maybe p (\z -> p ++ ",shape=\"" ++ z ++ "\"") (n_sh n)-                        a = maybe "" (l_f p') (n_pp n)-                    in concat [show k,a,";"]-        e_f (lhs,rhs,e) = let l = maybe "" (l_f "") (e_pp e)-                          in concat [show lhs,g_type_to_edge_symbol g_typ,show rhs,l,";"]+g_lift_pos_fn :: (v -> (Int,Int)) -> v -> [DOT_ATTR]+g_lift_pos_fn f v = let (c,r) = f v in [node_pos_attr (c * 100,r * 100)]+-}++lbl_to_dot :: G_TYPE -> [DOT_META_ATTR] -> GR_PP v e -> T.LBL v e -> [String]+lbl_to_dot g_typ opt (v_attr,e_attr) (v,e) =+    let ws s = if null s then "" else " " ++ s+        v_f (k,lbl) = concat [show k,ws (dot_attr_seq_pp (v_attr (k,lbl))),";"]+        e_f ((lhs,rhs),lbl) = concat [show lhs,g_type_to_edge_symbol g_typ,show rhs+                                     ,ws (dot_attr_seq_pp (e_attr ((lhs,rhs),lbl))),";"]     in concat [[g_type_to_string g_typ," g {"]-              ,map dot_attr_set_pp (dot_attr_collate (assoc_union opt dot_attr_def))-              ,map n_f (G.labNodes gr)-              ,map e_f (G.labEdges gr)+              ,map dot_attr_set_pp (dot_attr_collate opt)+              ,map v_f v+              ,map e_f e               ,["}"]] -g_to_udot :: [DOT_ATTR] -> GR_PP v e -> G.Gr v e -> [String]-g_to_udot o pp = g_to_dot G_UGRAPH o pp Nothing+lbl_to_udot :: [DOT_META_ATTR] -> GR_PP v e -> T.LBL v e -> [String]+lbl_to_udot o pp = lbl_to_dot G_UGRAPH o pp++fgl_to_dot :: G.Graph gr => G_TYPE -> [DOT_META_ATTR] -> GR_PP v e -> gr v e -> [String]+fgl_to_dot typ opt pp gr = lbl_to_dot typ opt pp (T.fgl_to_lbl gr)++fgl_to_udot :: G.Graph gr => [DOT_META_ATTR] -> GR_PP v e -> gr v e -> [String]+fgl_to_udot opt pp gr = lbl_to_udot opt pp (T.fgl_to_lbl gr)++-- * DOT-PROCESS++{- | Run /dot/ to generate a file type based on the output file extension+   (ie. .svg, .png, .jpeg, .gif)++   /-n/ must be given to not run the layout algorithm and to use position data in the /dot/ file.+-}+dot_to_ext :: [String] -> FilePath -> FilePath -> IO ()+dot_to_ext opt dot_fn ext_fn =+  let arg = opt ++ ["-T",tail (takeExtension ext_fn),"-o",ext_fn,dot_fn]+  in void (rawSystem "dot" arg)++-- | Alias for 'dot_to_ext'+dot_to_svg :: [String] -> FilePath -> FilePath -> IO ()+dot_to_svg = dot_to_ext+
Music/Theory/Graph/FGL.hs view
@@ -12,8 +12,12 @@  import qualified Control.Monad.Logic as L {- logict -} +import qualified Music.Theory.Graph.Type as T {- hmt -} import qualified Music.Theory.List as T {- hmt -} +fgl_to_lbl :: G.Graph gr => gr v e -> T.LBL v e+fgl_to_lbl gr = (G.labNodes gr,map (\(i,j,k) -> ((i,j),k)) (G.labEdges gr))+ -- | Synonym for 'G.noNodes'. g_degree :: G.Gr v e -> Int g_degree = G.noNodes@@ -66,17 +70,11 @@ -- | Edge, no label. type EDGE v = (v,v) --- | Graph as set of edges.-type GRAPH v = [EDGE v]- -- | Edge, with label. type EDGE_L v l = (EDGE v,l) --- | Graph as set of labeled edges.-type GRAPH_L v l = [EDGE_L v l]- -- | Generate a graph given a set of labelled edges.-g_from_edges_l :: (Eq v,Ord v) => GRAPH_L v e -> G.Gr v e+g_from_edges_l :: (Eq v,Ord v) => [EDGE_L v e] -> G.Gr v e g_from_edges_l e =     let n = nub (concatMap (\((lhs,rhs),_) -> [lhs,rhs]) e)         n_deg = length n@@ -90,7 +88,7 @@ -- -- > let g = G.mkGraph [(0,'a'),(1,'b'),(2,'c')] [(0,1,()),(1,2,())] -- > in g_from_edges_ul [('a','b'),('b','c')] == g-g_from_edges :: Ord v => GRAPH v -> G.Gr v ()+g_from_edges :: Ord v => [EDGE v] -> G.Gr v () g_from_edges = let f e = (e,()) in g_from_edges_l . map f  -- * Edges@@ -134,7 +132,7 @@  -- | Is the sequence of vertices a path at the graph, ie. are all -- adjacencies in the sequence edges.-e_is_path :: Eq t => GRAPH t -> [t] -> Bool+e_is_path :: Eq t => [EDGE t] -> [t] -> Bool e_is_path e sq =     case sq of       p:q:sq' -> elem_by e_undirected_eq (p,q) e && e_is_path e (q:sq')
+ Music/Theory/Graph/IO.hs view
@@ -0,0 +1,72 @@+{- | IO for graph files, graph6, sparse6 and digraph6 encodings.++<http://users.cecs.anu.edu.au/~bdm/nauty/>+<https://users.cecs.anu.edu.au/~bdm/data/formats.html>+-}+module Music.Theory.Graph.IO where++import Data.List.Split {- split -}+import System.Process {- process -}++import qualified Music.Theory.Graph.Type as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}++-- * G6 (graph6)++-- | Load Graph6 file, discard optional header if present.+g6_load :: FilePath -> IO [String]+g6_load fn = do+  s <- readFile fn+  let s' = if take 6 s == ">>graph6<<" then drop 6 s else s+  return (lines s')++-- | Load G6 file variant where each line is "Description\tG6"+g6_dsc_load :: FilePath -> IO [(String,String)]+g6_dsc_load fn = do+  s <- readFile fn+  let r = map (T.split_on_1_err "\t") (lines s)+  return r++-- | Call nauty-listg to transform a sequence of G6.+--   debian = nauty+g6_to_edg :: [String] -> IO [T.EDG]+g6_to_edg g6 = do+  r <- readProcess "nauty-listg" ["-q","-l0","-e"] (unlines g6)+  return (map T.edg_parse (chunksOf 2 (lines r)))++-- | 'T.edg_to_g' of 'g6_to_edg'+g6_to_gr :: [String] -> IO [T.G]+g6_to_gr = fmap (map T.edg_to_g) . g6_to_edg++-- | 'g6_to_edg' of 'g6_dsc_load'.+g6_dsc_load_edg :: FilePath -> IO [(String,T.EDG)]+g6_dsc_load_edg fn = do+  dat <- g6_dsc_load fn+  let (dsc,g6) = unzip dat+  gr <- g6_to_edg g6+  return (zip dsc gr)++-- | 'T.edg_to_g' of 'g6_dsc_load_edg'+g6_dsc_load_gr :: FilePath -> IO [(String,T.G)]+g6_dsc_load_gr = fmap (map (\(dsc,e) -> (dsc,T.edg_to_g e))) . g6_dsc_load_edg++{- | Generate the text format read by nauty-amtog.++> e = ((4,3),[(0,3),(1,3),(2,3)])+> m = T.edg_to_adj_mtx_undir e+> putStrLn (adj_mtx_to_am m)++-}+adj_mtx_to_am :: T.ADJ_MTX -> String+adj_mtx_to_am (nv,mtx) =+  unlines ["n=" ++ show nv+          ,"m"+          ,unlines (map (unwords . map show) mtx)]++-- | Call nauty-amtog to transform a sequence of ADJ_MTX to G6.+--+-- > adj_mtx_to_g6 [m,m]+adj_mtx_to_g6 :: [T.ADJ_MTX] -> IO [String]+adj_mtx_to_g6 adj = do+  r <- readProcess "nauty-amtog" ["-q"] (unlines (map adj_mtx_to_am adj))+  return (lines r)
Music/Theory/Graph/Johnson_2014.hs view
@@ -2,26 +2,33 @@ module Music.Theory.Graph.Johnson_2014 where  import Control.Monad {- base -}+import Data.Int {- base -} import Data.List {- base -}-import qualified Data.Map as M {- containers -} import Data.Maybe {- base -} +import qualified Control.Monad.Logic as L {- logict -}+import qualified Data.Map as M {- containers -}+import qualified Data.Graph.Inductive as G {- fgl -}+--import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -}+ import qualified Music.Theory.Combinations as T {- hmt -} import qualified Music.Theory.Graph.Dot as T {- hmt -} import qualified Music.Theory.Graph.FGL as T {- hmt -} import qualified Music.Theory.Key as T {- hmt -} import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Pitch.Note as T {- hmt -}+import qualified Music.Theory.Set.List as T {- hmt -} import qualified Music.Theory.Tuning as T {- hmt -}-import qualified Music.Theory.Tuning.Euler as T {- hmt -}+import qualified Music.Theory.Tuning.Graph.Euler as T {- hmt -}+import qualified Music.Theory.Tuple as T {- hmt -}+import qualified Music.Theory.Z as T {- hmt -}+import qualified Music.Theory.Z.Forte_1973 as T {- hmt -}+import qualified Music.Theory.Z.TTO as T {- hmt -} import qualified Music.Theory.Z.SRO as T {- hmt -}  -- * Common -type Z12 = Int--mod12 :: Integral a => a -> a-mod12 n = n `mod` 12+type Z12 = Int8  dif :: Num a => (a, a) -> a dif = uncurry (-)@@ -82,6 +89,12 @@ set_pp :: Show t => [t] -> String set_pp = intercalate "," . map show +tto_rel_to :: Integral t => T.Z t -> [t] -> [t] -> [T.TTO t]+tto_rel_to z p q = T.z_tto_rel 5 z (T.set p) (T.set q)++set_pp_tto_rel :: (Integral t, Show t) => T.Z t -> [t] -> [t] -> String+set_pp_tto_rel z p = intercalate "," . map T.tto_pp . tto_rel_to z p+ -- * Map  m_get :: Ord k => M.Map k v -> k -> v@@ -91,20 +104,78 @@ m_doi_of :: M.Map Int [Z12] -> Int -> Int -> Int -> Bool m_doi_of m n p q = doi_of n (m_get m p) (m_get m q) +-- * Edge++-- | Add /k/ as prefix to both left and right hand sides of edge.+e_add_id :: k -> [(t,u)] -> [((k,t),(k,u))]+e_add_id k = map (\(lhs,rhs) -> ((k,lhs),(k,rhs)))++gen_edges :: (t -> t -> Bool) -> [t] -> [(t,t)]+gen_edges f l = [(p,q) | p <- l, q <- l, f p q]++gen_u_edges :: Ord a => (a -> a -> Bool) -> [a] -> [(a, a)]+gen_u_edges = T.e_univ_select_u_edges+ -- * Graph -gen_graph_ul :: Ord v => [T.DOT_ATTR] -> (v -> String) -> [T.EDGE v] -> [String]-gen_graph_ul opt pp es = T.g_to_udot opt (T.gr_pp_lift_node_f pp) (T.g_from_edges es)+oh_def_opt :: [T.DOT_META_ATTR]+oh_def_opt =+  [("graph:layout","neato")+  ,("graph:epsilon","0.000001")+  ,("node:shape","plaintext")+  ,("node:fontsize","10")+  ,("node:fontname","century schoolbook")] +gen_graph :: Ord v => [T.DOT_META_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]+gen_graph opt pp es = T.fgl_to_udot (oh_def_opt ++ opt) pp (T.g_from_edges_l es)++gen_graph_ul :: Ord v => [T.DOT_META_ATTR] -> (v -> String) -> [T.EDGE v] -> [String]+gen_graph_ul opt pp es = T.fgl_to_udot (oh_def_opt ++ opt) (T.gr_pp_label_v pp) (T.g_from_edges es)+ gen_graph_ul_ty :: Ord v => String -> (v -> String) -> [T.EDGE v] -> [String] gen_graph_ul_ty ty = gen_graph_ul [("graph:layout",ty)] -gen_flt_graph :: (Ord t, Show t) => [T.DOT_ATTR] -> ([t] -> [t] -> Bool) -> [[t]] -> [String]-gen_flt_graph o f p = gen_graph_ul o set_pp (T.e_univ_select_u_edges f p)+gen_flt_graph_pp :: Ord t => [T.DOT_META_ATTR] -> ([t] -> String) -> ([t] -> [t] -> Bool) -> [[t]] -> [String]+gen_flt_graph_pp opt pp f p = gen_graph_ul opt pp (gen_u_edges f p) +gen_flt_graph :: (Ord t, Show t) => [T.DOT_META_ATTR] -> ([t] -> [t] -> Bool) -> [[t]] -> [String]+gen_flt_graph opt = gen_flt_graph_pp opt set_pp+ -- * P.12 --- | <http://localhost/rd/?t=j&e=2016-04-04.md>+-- > circ_5 12 0 == [0,7,2,9,4,11,6,1,8,3,10,5]+circ_5 :: Integral a => Int -> a -> [a]+circ_5 l n = take l (iterate (T.z_mod T.z12 . (+ 7)) (T.z_mod T.z12 n))++all_pairs :: [t] -> [u] -> [(t,u)]+all_pairs x y = [(p,q) | p <- x, q <- y]++adj :: [t] -> [(t,t)]+adj = T.adj2 1++adj_cyc :: [t] -> [(t,t)]+adj_cyc = T.adj2_cyclic 1++p12_c5_eset :: [(Int,Int)]+p12_c5_eset =+    let l1 = circ_5 4 9 -- [9,4,11,6]+        l2 = circ_5 5 10 -- [10,5,0,7,2]+        l3 = circ_5 3 1 -- [1,8,3]+        align p q = filter ((== 4) . T.z_mod T.z12 . dif) (all_pairs p q)+    in concatMap adj [l1,l2,l3] ++ align l1 l2 ++ align l2 l3++e_add_label :: (T.EDGE v -> l) -> [T.EDGE v] -> [T.EDGE_L v l]+e_add_label f = let g (p,q) = ((p,q),f (p,q)) in map g++p12_c5_gr :: [String]+p12_c5_gr =+    let o = [("graph:start","187623")+            ,("node:fontsize","10")+            ,("edge:fontsize","9")]+        e_l = e_add_label (i_to_ic . absdif) p12_c5_eset+    in gen_graph o (\(_,v) -> [("label",T.pc_pp v)],\(_,e) -> [("label",show e)]) e_l++-- > T.euler_plane_r p12_euler_plane == [1/1,16/15,9/8,6/5,5/4,4/3,45/32,3/2,8/5,5/3,16/9,15/8] p12_euler_plane :: T.Euler_Plane Rational p12_euler_plane =     let f = T.fold_ratio_to_octave_err@@ -119,36 +190,90 @@  -- * P.14 +p14_eset :: ([(Int, Int)], [(Int, Int)], [(Int, Int)])+p14_eset =+  let univ = [0 .. 11]+      trs n = map (T.z_mod T.z12 . (+ n))+      e_par = zip univ univ+      e_rel = zip univ (trs 9 univ)+      e_med = zip univ (trs 4 univ)+  in (e_par,e_rel,e_med)++p14_mk_e :: [(Int, Int)] -> [(T.Key,T.Key)]+p14_mk_e =+  let pc_to_key m pc = let Just (n,a) = T.pc_to_note_alteration_ks pc in (n,a,m)+      e_lift (lhs,rhs) = (pc_to_key T.Major_Mode lhs,pc_to_key T.Minor_Mode rhs)+  in map e_lift++p14_edges_u :: [(T.Key,T.Key)]+p14_edges_u =+  let (e_par,e_rel,e_med) = p14_eset+  in p14_mk_e (concat [e_par,e_rel,e_med])+ p14_edges :: [(T.Key,T.Key)] p14_edges =-    let univ = [0::Int .. 11]-        trs n = map (mod12 . (+ n))-        e_par = zip univ univ-        e_rel = zip univ (trs 9 univ)-        e_med = zip univ (trs 4 univ)-        del_par = [10]-        del_rel = [5,6]-        del_med = [2,5,8,11]-        rem_set r = filter (\(lhs,_) -> lhs `notElem` r)-        pc_to_key m pc = let Just (n,a) = T.pc_to_note_alteration_ks pc in (n,a,m)-        e_lift (lhs,rhs) = (pc_to_key T.Major_Mode lhs,pc_to_key T.Minor_Mode rhs)-        e_mod = concat [rem_set del_par e_par,rem_set del_rel e_rel,rem_set del_med e_med]-    in map e_lift e_mod+  let (e_par,e_rel,e_med) = p14_eset+      del_par = [10]+      del_rel = [5,6]+      del_med = [2,5,8,11]+      rem_set r = filter (\(lhs,_) -> lhs `notElem` r)+      e_mod = concat [rem_set del_par e_par,rem_set del_rel e_rel,rem_set del_med e_med]+  in p14_mk_e e_mod +p14_mk_gr :: [T.DOT_META_ATTR] -> [T.EDGE T.Key] -> [String]+p14_mk_gr opt e =+    let opt' = ("graph:start","168732") : opt+        pp = T.gr_pp_label_v T.key_lc_uc_pp+        gr = T.g_from_edges e+    in T.fgl_to_udot opt' pp gr++p14_gr_u :: [String]+p14_gr_u =+  p14_mk_gr+  [("edge:len","1.5")+  ,("edge:fontsize","6")+  ,("node:shape","box")+  ,("node:fontsize","10")+  ,("node:fontname","century schoolbook")]+  p14_edges_u+ p14_gr :: [String]-p14_gr =-    let opt = [("graph:start","168732")]-        pp = T.gr_pp_lift_node_f T.key_lc_uc_pp-        gr = T.g_from_edges p14_edges-    in T.g_to_udot opt pp gr+p14_gr = p14_mk_gr [] p14_edges +p14_gen_tonnetz_n :: Int -> [Int] -> [Int] -> [Int]+p14_gen_tonnetz_n n k x =+  let gen_neighbours_n l z = map (+ z) l ++ map (z -) l+  in if n == 0+     then x+     else let r = nub (x ++ concatMap (gen_neighbours_n k) x)+          in p14_gen_tonnetz_n (n - 1) k r++p14_gen_tonnetz_e :: Int -> [Int] -> [Int] -> [((Int, Int), Int)]+p14_gen_tonnetz_e n k =+    let gen_e x y = ((min x y,max x y),abs (x - y))+        gen_e_n d_set x y = if abs (x - y) `elem` d_set then Just (gen_e x y) else Nothing+        f [p,q] = gen_e_n k p q+        f _ = error "p14_gen_tonnetz_e"+    in mapMaybe f . T.combinations 2 . p14_gen_tonnetz_n n k++-- NEO-RIEMANNIAN TONNETTZ+p14_nrt_gr :: [String]+p14_nrt_gr =+  let e = p14_gen_tonnetz_e 3 [7,9,16] [48]+      o = [("node:shape","circle")+          ,("node:fontsize","10")+          ,("node:fontname","century schoolbook")+          ,("edge:len","1")]+      pp = (\(_,v) -> [("label",T.pc_pp (T.z_mod T.z12 v))],\_ -> [])+  in gen_graph o pp e+ -- * P.31  p31_f_4_22 :: [Z12] p31_f_4_22 = [0,2,4,7]  p31_e_set :: [([Z12],[Z12])]-p31_e_set = T.e_univ_select_u_edges (doi_of 3) (map sort (T.z_sro_ti_related mod12 p31_f_4_22))+p31_e_set = T.e_univ_select_u_edges (doi_of 3) (map sort (T.z_sro_ti_related T.z12 p31_f_4_22))  p31_gr :: [String] p31_gr = gen_graph_ul [] set_pp p31_e_set@@ -158,15 +283,32 @@ p114_f_3_7 :: [Z12] p114_f_3_7 = [0,2,5] +p114_mk_o :: Show t => t -> [T.DOT_META_ATTR]+p114_mk_o el =+  [("node:shape","box")+  ,("edge:len",show el)+  ,("edge:fontsize","10")]+ p114_mk_gr :: Double -> ([Z12] -> [Z12] -> Bool) -> [String] p114_mk_gr el flt =-    let o = [("node:shape","box")-            ,("edge:len",show el)]-    in gen_flt_graph o flt (map sort (T.z_sro_ti_related mod12 p114_f_3_7))+  let n = (map sort (T.z_sro_ti_related T.z12 p114_f_3_7))+  in gen_flt_graph (p114_mk_o el) flt n +p114_f37_sc_pp :: [Z12] -> String+p114_f37_sc_pp = set_pp_tto_rel T.z12 [0,2,5]++p114_g0 :: [String]+p114_g0 =+  let mk_e flt = gen_u_edges flt (map sort (T.z_sro_ti_related T.z12 p114_f_3_7))+  in gen_graph_ul (p114_mk_o (2.5::Double)) p114_f37_sc_pp (mk_e (doi_of 2))++p114_g1 :: [String]+p114_g1 = p114_mk_gr 2.5 (doi_of 2)+ p114_gr_set :: [(String,[String])] p114_gr_set =-  [("p114.1.dot",p114_mk_gr 2.5 (doi_of 2))+  [("p114.0.dot",p114_g0)+  ,("p114.1.dot",p114_g1)   ,("p114.2.dot"    ,let o = [("edge:len","1.25")]     in gen_flt_graph o (loc_dif_of 1) (T.combinations 3 [1::Int .. 6]))@@ -223,35 +365,103 @@  -- * P.162 +-- > length p162_ch == 30+p162_ch :: [[Int]]+p162_ch =+  let n = [0::Int,1,2,3,4,5,6,7,8]+      c = T.combinations 4 n+  in filter ((== 1) . (`mod` 4) . sum) c++-- > length p162_e == 47+p162_e :: [T.EDGE [Int]]+p162_e = T.e_univ_select_u_edges (doi_of 3) p162_ch+ p162_gr :: [String] p162_gr =-    let n = [0::Int,1,2,3,4,5,6,7,8]-        c = T.combinations 4 n-        ch = filter ((== 1) . (`mod` 4) . sum) c-        opt = [("graph:layout","neato")+    let opt = [("graph:layout","neato")               ,("edge:len","1.75")]-    in gen_graph_ul opt set_pp (T.e_univ_select_u_edges (doi_of 3) ch)+    in gen_graph_ul opt set_pp p162_e  -- * P.172 +-- > M.size p172_nd_map == 24 p172_nd_map :: M.Map Int [Z12] p172_nd_map =-    let nd_exp = map sort (T.z_sro_ti_related mod12 [0,1,3,7])+    let nd_exp = map sort (T.z_sro_ti_related T.z12 [0,1,3,7])     in M.fromList (zip [0..] nd_exp) +p172_nd_e_set :: [(Int,Int)]+p172_nd_e_set = T.e_univ_select_u_edges (m_doi_of p172_nd_map 0) [0..23]++p172_nd_e_set_alt :: [T.EDGE Int]+p172_nd_e_set_alt = concatMap (T.e_path_to_edges . T.close 1) p172_cyc0++p172_gr :: G.Gr () ()+p172_gr = G.mkUGraph [0..23] p172_nd_e_set+ p172_set_pp :: Int -> String p172_set_pp = set_pp . m_get p172_nd_map +-- > let (c0,c1) = p172_all_cyc p172_gr+-- > (length c0,length c1) == (48,48)+p172_all_cyc :: ([[Int]], [[Int]])+p172_all_cyc =+    let [a,b] = T.g_partition p172_gr+    in (L.observeAll (T.ug_hamiltonian_path_ml_0 a)+       ,L.observeAll (T.ug_hamiltonian_path_ml_0 b))++p172_cyc0 :: [[Int]]+p172_cyc0 = map (!! 0) [fst p172_all_cyc,snd p172_all_cyc]++p172_g1 :: [String]+p172_g1 = gen_graph_ul [("edge:len","2.0")] p172_set_pp p172_nd_e_set++p172_g2 :: [String]+p172_g2 = gen_graph_ul [] p172_set_pp p172_nd_e_set_alt++p172_g3 :: [String]+p172_g3 =+  let m_set_pp_tto_rel = set_pp_tto_rel T.z12 [0,1,3,7] . m_get p172_nd_map+  in gen_graph_ul [("node:shape","box"),("edge:len","2.0")] m_set_pp_tto_rel p172_nd_e_set++-- | 'T.TTO' T/n/.+tto_tn :: Integral t => t -> T.TTO t+tto_tn n = T.TTO (T.z_mod T.z12 n) 1 False++-- | 'Z.TTO' T/n/I.+tto_tni :: Integral t => t -> T.TTO t+tto_tni n = T.TTO (T.z_mod T.z12 n) 1 True++gen_tto_alt_seq :: Integral t => (t -> T.TTO t,t -> T.TTO t) -> Int -> t -> t -> t -> [T.TTO t]+gen_tto_alt_seq (f,g) k n m x =+    let t = map f (take k [x,x + n ..])+        i = map g (take k [x + m,x + m + n ..])+    in T.interleave t i++-- | /k/ is length of the T & I sequences, /n/ is the T & I sequence+-- interval, /m/ is the interval between the T & I sequence.+--+-- > r = ["T0 T5I T3 T8I T6 T11I T9 T2I","T1 T6I T4 T9I T7 T0I T10 T3I"]+-- > map (unwords . map T.tto_pp . gen_tni_seq 4 3 5) [0,1] == r+gen_tni_seq :: Integral t => Int -> t -> t -> t -> [T.TTO t]+gen_tni_seq = gen_tto_alt_seq (tto_tn,tto_tni)++-- > putStrLn $ unlines $ map (unwords . map Z.tto_pp) c4+p172_c4 :: [[T.TTO Int]]+p172_c4 = map (gen_tni_seq 3 4 9) [0 .. 3] ++ map (gen_tni_seq 2 6 11) [0 .. 5]++tto_seq_edges :: (Show t,Num t,Eq t) => [[T.TTO t]] -> [(String, String)]+tto_seq_edges = nub . sort . concatMap (map T.t2_sort . adj_cyc . map T.tto_pp)++p172_g4 :: [String]+p172_g4 = gen_graph_ul [("edge:len","2.0")] id (tto_seq_edges p172_c4)+ p172_gr_set :: [(String,[String])] p172_gr_set =-    [("p172.0.dot"-     ,let nd_e_set = T.e_univ_select_u_edges (m_doi_of p172_nd_map 0) [0..23]-      in gen_graph_ul_ty "circo" p172_set_pp nd_e_set)-    ,("p172.1.dot"-     ,let nd_e_set = concatMap T.e_path_to_edges-                     [[22,11,20,9,18,7,16,5,14,3,12,1,22]-                     ,[23,2,13,8,19,10,21,4,15,6,17,0,23]]-      in gen_graph_ul_ty "circo" p172_set_pp nd_e_set)]+    [("p172.0.dot",p172_g1)+    ,("p172.1.dot",p172_g2)+    ,("p172.2.dot",p172_g3)+    ,("p172.3.dot",p172_g4)]  -- * P.177 @@ -265,21 +475,149 @@  p177_gr_set :: [(String,[String])] p177_gr_set =-    let p_set = concatMap (T.z_sro_ti_related mod12) [[0::Int,1,4,6],[0,1,3,7]]+    let p_set = concatMap (T.z_sro_ti_related T.z12) [[0::Int,1,4,6],[0,1,3,7]]     in [("p177.0.dot",gen_graph_ul [] set_pp (map (partition_ic 4) p_set))        ,("p177.1.dot",gen_graph_ul_ty "circo" set_pp (map (partition_ic 6) p_set))        ,("p177.2.dot"-        ,let gr_pp = T.gr_pp_lift_node_f set_pp+        ,let gr_pp = T.gr_pp_label_v set_pp              gr = T.g_from_edges (map (partition_ic 6) p_set)-         in T.g_to_udot [("edge:len","1.5")] gr_pp gr)]+         in T.fgl_to_udot [("edge:len","1.5")] gr_pp gr)] +-- * P.178++type SC = [Int]+type PCSET = [Int]++ait :: [SC]+ait = map T.sc ["4-Z15","4-Z29"]++-- | List of pcsets /s/ where /prime(p+s)=r/ and /prime(q+s)=r/.+-- /#p/ and /#q/ must be equal, and less than /#r/.+--+-- > mk_bridge (T.sc "4-Z15") [0,6] [1,7] == [[2,5],[8,11]]+-- > mk_bridge (T.sc "4-Z29") [0,6] [1,7] == [[2,11],[5,8]]+mk_bridge :: SC -> PCSET -> PCSET -> [PCSET]+mk_bridge r p q =+    let n = length r - length p+        c = T.combinations n [0..11]+        f s = T.z_forte_prime T.z12 (p ++ s) == r && T.z_forte_prime T.z12 (q ++ s) == r+    in filter f c++-- | 'concatMap' of 'mk_bridge'.+--+-- > mk_bridge_set ait [0,6] [1,7] == [[2,5],[8,11],[2,11],[5,8]]+mk_bridge_set :: [SC] -> PCSET -> PCSET -> [PCSET]+mk_bridge_set r_set p q = concatMap (\r -> mk_bridge r p q) r_set++mk_bridge_set_seq :: [SC] -> [PCSET] -> [[PCSET]]+mk_bridge_set_seq r_set k_seq =+    case k_seq of+      p:q:k_seq' -> mk_bridge_set r_set p q : mk_bridge_set_seq r_set (q : k_seq')+      _ -> []++-- > zip [0..] (mk_bridge_set_seq ait p178_i6_seq)+p178_i6_seq :: [PCSET]+p178_i6_seq = map (sort . (\n -> T.z_pcset T.z12 [n,n+6])) [0..6]++p178_ch :: [(PCSET,[PCSET],PCSET)]+p178_ch = zip3 p178_i6_seq (mk_bridge_set_seq ait p178_i6_seq) (tail p178_i6_seq)++type ID = Char++-- | Add 'ID' to vertices, the @2,11@ the is between @0,6@ and @1,7@+-- is /not/ the same @2,11@ that is between @3,9@ and @4,10@.+p178_e :: [((ID,PCSET),(ID,PCSET))]+p178_e =+    let f k (p,c,q) = map (\x -> (('.',p),(k,x))) c ++ map (\x -> ((k,x),('.',q))) c+    in concat (zipWith f ['a'..] p178_ch)++p178_gr_1 :: [String]+p178_gr_1 =+    let opt = [("node:shape","rectangle")+              ,("node:start","1362874")+              ,("edge:len","2")]+    in gen_graph_ul opt (set_pp . snd) p178_e++p178_gr_2 :: [String]+p178_gr_2 =+    let opt = [("node:shape","point")]+    in gen_graph_ul opt (const "") p178_e++-- * P.196++p196_gr :: [String]+p196_gr = gen_flt_graph [("edge:len","1.25")] (loc_dif_of 1) (T.combinations 3 [1::Int .. 6])++-- * P.201++type SET = [Int]+type E = (SET,SET)++bd_9_3_2_12 :: [SET]+bd_9_3_2_12 =+    [[0,1,2],[0,1,2],[0,3,4],[0,3,4],[0,5,6],[0,5,7],[0,6,8],[0,7,8]+    ,[1,3,5],[1,3,8],[1,4,5],[1,4,8],[1,6,7],[1,6,7]+    ,[2,3,6],[2,3,7],[2,4,6],[2,4,7],[2,5,8],[2,5,8]+    ,[3,5,6],[3,7,8]+    ,[4,5,7],[4,6,8]]++p201_mk_e :: [Int] -> [E]+p201_mk_e =+    let f n s = if n `elem` s then Just ([n],sort (n `delete` s)) else Nothing+        g n = mapMaybe (f n) bd_9_3_2_12+    in concatMap g++p201_e :: [[E]]+p201_e = map p201_mk_e [[0,3,4],[1,6,7],[2,5,8]]++p201_o :: [T.DOT_META_ATTR]+p201_o =+  [("graph:splines","false")+  ,("node:shape","box")+  ,("edge:len","1.75")]++-- > length p201_gr_set+p201_gr_set :: [[String]]+p201_gr_set = map (gen_graph_ul p201_o set_pp) p201_e++p201_gr_join :: [String]+p201_gr_join =+    let e = zipWith e_add_id [0::Int ..] p201_e+    in gen_graph_ul p201_o (set_pp . snd) (concat e)++-- * P.205++bd_9_3_2_34 :: [SET]+bd_9_3_2_34 =+    [[0,1,2],[0,1,3],[0,2,4],[0,3,4]+    ,[0,5,6],[0,5,7],[0,6,8],[0,7,8]+    ,[1,2,5],[1,3,6],[1,4,5],[1,4,8]+    ,[1,6,7],[1,7,8],[2,3,6],[2,3,7]+    ,[2,4,7],[2,5,8],[2,6,8],[3,4,8]+    ,[3,5,7],[3,5,8],[4,5,6],[4,6,7]]++p205_mk_e :: [Int] -> [E]+p205_mk_e =+    let f n s = if n `elem` s then Just ([n],sort (n `delete` s)) else Nothing+        g n = mapMaybe (f n) bd_9_3_2_34+    in concatMap g++p205_gr :: [String]+p205_gr =+    let o = [("graph:splines","false"),("node:shape","box"),("edge:len","2.25")]+    in gen_graph_ul o set_pp (p205_mk_e [0..8])+ -- * IO -wr_graphs :: IO ()-wr_graphs = do-  let f (nm,gr) = writeFile ("/home/rohan/sw/hmt/data/dot/tj_oh_" ++ nm) (unlines gr)-  f ("p012.dot",p12_euler_plane_gr)-  f ("p014.dot",p14_gr)+-- > wr_graphs "/home/rohan/sw/hmt/data/dot/tj/oh/"+wr_graphs :: FilePath -> IO ()+wr_graphs dir = do+  let f (nm,gr) = writeFile (dir ++ "tj_oh_" ++ nm) (unlines gr)+  f ("p012.1.dot",p12_c5_gr)+  f ("p012.2.dot",p12_euler_plane_gr)+  f ("p014.1.dot",p14_gr_u)+  f ("p014.2.dot",p14_gr)+  f ("p014.3.dot",p14_nrt_gr)   f ("p031.dot",p31_gr)   mapM_ f p114_gr_set   f ("p125.dot",p125_gr)@@ -288,3 +626,9 @@   f ("p162.dot",p162_gr)   mapM_ f p172_gr_set   mapM_ f p177_gr_set+  f ("p178.1.dot",p178_gr_1)+  f ("p178.2.dot",p178_gr_2)+  f ("p196.dot",p196_gr)+  mapM_ f (zip ["p201.1.dot","p201.2.dot","p201.3.dot"] p201_gr_set)+  f ("p201.4.dot",p201_gr_join)+  f ("p205.dot",p205_gr)
+ Music/Theory/Graph/LCF.hs view
@@ -0,0 +1,109 @@+{- | LCF (Lederberg/Coxeter/Frucht) notation++The notation only applies to Hamiltonian graphs, since it achieves its+symmetry and conciseness by placing a Hamiltonian cycle in a circular+embedding and then connecting specified pairs of nodes with edges. (EW)++-}+module Music.Theory.Graph.LCF where++import Data.Complex {- base -}+import Data.List {- base -}++import qualified Music.Theory.Graph.Type as T {- hmt -}++type LCF = ([Int],Int)+type R = Double++lcf_seq :: LCF -> [Int]+lcf_seq (l,k) = concat (replicate k l)++lcf_degree :: LCF -> Int+lcf_degree (l,k) = length l * k++-- | LCF to edge list.+lcf_to_edg :: LCF -> T.EDG+lcf_to_edg (l,k) =+  let v_n = length l * k+      add i j = (i + j) `mod` v_n+      v = [0 .. v_n - 1]+  in ((v_n,v_n + (v_n `div` 2))+     ,concat [[(i,i `add` 1) | i <- v]+             ,nub (sort (map T.e_sort (zip v (zipWith add v (lcf_seq (l,k))))))])++-- | LCF edge-list to graph labeled with circular co-ordinates.+edg_circ_gr :: R -> T.EDG -> T.LBL (R,R) ()+edg_circ_gr rad ((n,_),e) =+  let polar_to_rectangular (mg,ph) = let c = mkPolar mg ph in (realPart c,imagPart c)+      ph_incr = (2 * pi) / fromIntegral n+      v = zip [0 .. n - 1] (map polar_to_rectangular (zip (repeat rad) [0, ph_incr ..]))+  in (v,zip e (repeat ()))++{- | LCF graph set given at <http://mathworld.wolfram.com/LCFNotation.html>++> length lcf_mw_set == 57+> length (nub (map snd lcf_mw_set)) == 57 -- IE. UNIQ+-}+lcf_mw_set :: [(String, LCF)]+lcf_mw_set =+  [("Tetrahedral graph",([2,-2],2)) -- ([2],4)+  ,("Utility graph",([3],6)) -- ([3,-3],3)+  ,("3-prism graph",([-3,-2,2],2))+  ,("Cubical graph",([3,-3],4))+  ,("Wagner graph",([4],8))+  ,("3-matchstick graph",([-2,-2,2,2],2))+  ,("4-Möbius ladder",([-4],8))+  ,("5-Möbius ladder",([-5],10))+  ,("5-prism graph",([-5,3,-4,4,-3],2))+  ,("Bidiakis cube",([6,4,-4],4))+  ,("Franklin graph",([5,-5],6))+  ,("Frucht graph",([-5,-2,-4,2,5,-2,2,5,-2,-5,4,2],1))+  ,("Truncated tetrahedral graph",([2,6,-2],4))+  ,("Generalized Petersen graph (6,2)",([-5,2,4,-2,-5,4,-4,5,2,-4,-2,5],1))+  ,("6-Möbius ladder",([-6],12))+  ,("6-prism graph",([-3,3],6))+  ,("Heawood graph",([5,-5],7))+  ,("Generalized Petersen graph (7,2)",([-7,-5,4,-6,-5,4,-4,-7,4,-4,5,6,-4,5],1))+  ,("7-Möbius ladder",([-7],14))+  ,("7-prism graph",([-7,5,3,-6,6,-3,-5],2))+  ,("Cubic vertex-transitive graph Ct19",([-7,7],8))+  ,("Möbius-Kantor graph",([5,-5],8))+  ,("8-Möbius ladder",([-8],16))+  ,("8-prism graph",([-3,3],8))+  ,("Pappus graph",([5,7,-7,7,-7,-5],3))+  ,("Cubic vertex-transitive graph Ct20",([-7,7],9)) -- ([5,-5],9)+  ,("Cubic vertex-transitive graph Ct23",([-9,-2,2],6))+  ,("Generalized Petersen graph (9,2)",([-9,-8,-4,-9,4,8],3))+  ,("Generalized Petersen graph (9,3)",([-9,-6,2,5,-2,-9,5,-9,-5,-9,2,-5,-2,6,-9,2,-9,-2],1))+  ,("9-Möbius ladder",([-9],18))+  ,("9-prism graph",([-9,7,5,3,-8,8,-3,-5,-7],2))+  ,("Desargues graph",([5,-5,9,-9],5))+  ,("Dodecahedral graph",([10,7,4,-4,-7,10,-4,7,-7,4],2))+  ,("Cubic vertex-transitive graph Ct25",([-7,7],10))+  ,("Cubic vertex-transitive graph Ct28",([-6,-6,6,6],5))+  ,("Cubic vertex-transitive graph Ct29",([-9,9],10))+  ,("Generalized Petersen graph (10,4)",([-10,-7,5,-5,7,-6,-10,-5,5,6],2))+  ,("Largest cubic nonplanar graph with diameter 3",([-10,-7,-5,4,7,-10,-7,-4,5,7,-10,-7,6,-5,7,-10,-7,5,-6,7],1))+  ,("10-Möbius ladder",([-10],20))+  ,("10-prism graph",([-3,3],10))+  ,("McGee graph",([12,7,-7],8))+  ,("Truncated cubical graph",([2,9,-2,2,-9,-2],4))+  ,("Truncated octahedral graph",([3,-7,7,-3],6))+  ,("Nauru graph",([5,-9,7,-7,9,-5],4))+  ,("F26A graph",([-7,7],13))+  ,("Tutte-Coxeter graph",([-13,-9,7,-7,9,13],5))+  ,("Dyck graph",([5,-5,13,-13],8))+  ,("Gray graph",([-25,7,-7,13,-13,25],9))+  ,("Truncated dodecahedral graph",([30,-2,2,21,-2,2,12,-2,2,-12,-2,2,-21,-2,2,30,-2,2,-12,-2,2,21,-2,2,-21,-2,2,12,-2,2],2))+  ,("Harries graph",([-29,-19,-13,13,21,-27,27,33,-13,13,19,-21,-33,29],5))+  ,("Harries-Wong graph",([9,25,31,-17,17,33,9,-29,-15,-9,9,25,-25,29,17,-9,9,-27,35,-9,9,-17,21,27,-29,-9,-25,13,19,-9,-33,-17,19,-31,27,11,-25,29,-33,13,-13,21,-29,-21,25,9,-11,-19,29,9,-27,-19,-13,-35,-9,9,17,25,-9,9,27,-27,-21,15,-9,29,-29,33,-9,-25],1))+  ,("Balaban 10-cage",([-9,-25,-19,29,13,35,-13,-29,19,25,9,-29,29,17,33,21,9,-13,-31,-9,25,17,9,-31,27,-9,17,-19,-29,27,-17,-9,-29,33,-25,25,-21,17,-17,29,35,-29,17,-17,21,-25,25,-33,29,9,17,-27,29,19,-17,9,-27,31,-9,-17,-25,9,31,13,-9,-21,-33,-17,-29,29],1))+  ,("Foster graph",([17,-9,37,-37,9,-17],15))+  ,("Biggs-Smith graph",([16,24,-38,17,34,48,-19,41,-35,47,-20,34,-36,21,14,48,-16,-36,-43,28,-17,21,29,-43,46,-24,28,-38,-14,-50,-45,21,8,27,-21,20,-37,39,-34,-44,-8,38,-21,25,15,-34,18,-28,-41,36,8,-29,-21,-48,-28,-20,-47,14,-8,-15,-27,38,24,-48,-18,25,38,31,-25,24,-46,-14,28,11,21,35,-39,43,36,-38,14,50,43,36,-11,-36,-24,45,8,19,-25,38,20,-24,-14,-21,-8,44,-31,-38,-28,37],1))+  ,("Balaban 11-cage",([44,26,-47,-15,35,-39,11,-27,38,-37,43,14,28,51,-29,-16,41,-11,-26,15,22,-51,-35,36,52,-14,-33,-26,-46,52,26,16,43,33,-15,17,-53,23,-42,-35,-28,30,-22,45,-44,16,-38,-16,50,-55,20,28,-17,-43,47,34,-26,-41,11,-36,-23,-16,41,17,-51,26,-33,47,17,-11,-20,-30,21,29,36,-43,-52,10,39,-28,-17,-52,51,26,37,-17,10,-10,-45,-34,17,-26,27,-21,46,53,-10,29,-50,35,15,-47,-29,-41,26,33,55,-17,42,-26,-36,16],1))+  ,("Ljubljana graph",([47,-23,-31,39,25,-21,-31,-41,25,15,29,-41,-19,15,-49,33,39,-35,-21,17,-33,49,41,31,-15,-29,41,31,-15,-25,21,31,-51,-25,23,9,-17,51,35,-29,21,-51,-39,33,-9,-51,51,-47,-33,19,51,-21,29,21,-31,-39],2))+  ,("Tutte 12-cage",([17,27,-13,-59,-35,35,-11,13,-53,53,-27,21,57,11,-21,-57,59,-17],7))]++-- Local Variables:+-- truncate-lines:t+-- End:
+ Music/Theory/Graph/OBJ.hs view
@@ -0,0 +1,100 @@+{- | Graph/OBJ functions++This module is primarily for reading & writing graphs where vertices are labeled (x,y,z) to OBJ files.++PDF=<http://www.cs.utah.edu/~boulos/cs3505/obj_spec.pdf>+TXT=<http://www.martinreddy.net/gfx/3d/OBJ.spec>+-}+module Music.Theory.Graph.OBJ where++import Data.Either {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Music.Theory.Graph.Type as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -}++{- | Requires (but does not check) that graph vertices be indexed [0 .. #v - 1]+OBJ file vertices are one-indexed.+If /wr_p/ is True point (p) entries are written.+-}+v3_graph_to_obj_opt :: RealFloat n => Bool -> Int -> T.LBL (n,n,n) () -> [String]+v3_graph_to_obj_opt wr_p k (v,e) =+  let v_pp (_,(x,y,z)) = unwords ("v" : map (T.realfloat_pp k) [x,y,z])+      e_pp ((i,j),()) = unwords ("l" : map show [i + 1,j + 1])+  in concat [map v_pp v+            ,if wr_p then map (\i -> "p " ++ show i) [1 .. length v] else []+            ,map e_pp e]++-- | 'v3_graph_to_obj_opt' 'False'.+v3_graph_to_obj :: RealFloat n => Int -> T.LBL (n,n,n) () -> [String]+v3_graph_to_obj = v3_graph_to_obj_opt False++-- | 'writeFile' of 'v3_graph_to_obj'.+obj_store_v3_graph :: RealFloat n => Int -> FilePath -> (T.LBL (n,n,n) ()) -> IO ()+obj_store_v3_graph k fn = writeFile fn . unlines . v3_graph_to_obj k++-- | Read OBJ file consisting only of /v/, /l/ and /f/ (and optionally /p/, which are ignored) entries.+obj_to_v3_graph :: Read n => [String] -> T.LBL (n,n,n) ()+obj_to_v3_graph txt =+  let l_verify (i,j) = if i < 0 || j < 0 then error "obj_to_v3_graph?" else (i,j)+      e_read (i,j) = l_verify (read i - 1,read j - 1)+      f s = case words s of+              ["v",x,y,z] -> Just (Left (read x,read y,read z))+              "l":ix -> Just (Right (map e_read (T.adj2 1 ix)))+              "f":ix -> Just (Right (map e_read (T.adj2_cyclic 1 ix)))+              ["p",_] -> Nothing+              _ -> error "obj_to_v3_graph?"+      (v,l) = partitionEithers (mapMaybe f txt)+  in (zip [0..] v,zip (concat l) (repeat ()))++-- | 'obj_to_v3_graph' of 'readFile'.+obj_load_v3_graph :: Read n => FilePath -> IO (T.LBL (n,n,n) ())+obj_load_v3_graph = fmap (obj_to_v3_graph . lines) . readFile++-- * F64++-- | Type-specialised.+v3_graph_to_obj_f64 :: Int -> T.LBL (Double,Double,Double) () -> [String]+v3_graph_to_obj_f64 = v3_graph_to_obj++-- | Type-specialised.+obj_store_v3_graph_f64 :: Int -> FilePath -> (T.LBL (Double,Double,Double) ()) -> IO ()+obj_store_v3_graph_f64 = obj_store_v3_graph++-- | Type-specialised.+obj_load_v3_graph_f64 :: FilePath -> IO (T.LBL (Double,Double,Double) ())+obj_load_v3_graph_f64 = obj_load_v3_graph++-- * FACES++-- | Rewrite a set of faces (CCW triples of (x,y,z) coordinates) as (vertices,[[v-indices]]).+--   Vertices are zero-indexed.+obj_face_set_dat :: Ord n => [[(n,n,n)]] -> ([(n,n,n)],[[Int]])+obj_face_set_dat t =+  let v = nub (sort (concat t))+      v_ix = zip [0..] v+      f = map (map (flip T.reverse_lookup_err v_ix)) t+  in (v,f)++-- | Inverse of 'obj_face_set_dat'.+obj_face_dat_set :: ([(n,n,n)],[[Int]]) -> [[(n,n,n)]]+obj_face_dat_set (v,f) = map (map (flip T.lookup_err (zip [0..] v))) f++obj_face_dat_fmt :: (Show n, Ord n) => ([(n,n,n)],[[Int]]) -> [String]+obj_face_dat_fmt (v,f) =+  let v_f (x,y,z) = unwords ["v",show x,show y,show z]+      f_f = unwords . ("f" :) . map show . map (+ 1)+  in map v_f v ++ map f_f f++obj_face_dat_store :: (Show n, Ord n) => FilePath -> ([(n,n,n)],[[Int]]) -> IO ()+obj_face_dat_store fn = writeFile fn . unlines . obj_face_dat_fmt++-- | Format 'obj_face_set_dat' as an OBJ file. OBJ files are one-indexed.+obj_face_set_fmt :: (Show n, Ord n) => [[(n,n,n)]] -> [String]+obj_face_set_fmt = obj_face_dat_fmt . obj_face_set_dat++-- | 'writeFile' of 'obj_face_set_fmt'+obj_face_set_store :: (Show n, Ord n) => FilePath -> [[(n,n,n)]] -> IO ()+obj_face_set_store fn = writeFile fn . unlines . obj_face_set_fmt
+ Music/Theory/Graph/PLY.hs view
@@ -0,0 +1,87 @@+{- | Graph/PLY functions.++This module is used instead of 'Music.Theory.Graph.OBJ' when edges are coloured.++There is no reader.++Greg Turk "The PLY Polygon File Format" (1994)++SEE "PLY_FILES.txt" in <https://www.cc.gatech.edu/projects/large_models/files/ply.tar.gz>++-}+module Music.Theory.Graph.PLY where++import Data.List {- base -}++import qualified Music.Theory.Graph.Type as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -}++-- | ASCII PLY-1.0 header for V3 graph of (#v,#e).+--   Edges and faces are (r,g,b) coloured.+--+-- > putStrLn $ unlines $ ply_header (8,6,0)+ply_header :: (Int,Int,Int) -> [String]+ply_header (n_v,n_f,n_e) =+  concat+  [["ply"+   ,"format ascii 1.0"+   ,"element vertex " ++ show n_v+   ,"property float x"+   ,"property float y"+   ,"property float z"]+  ,if n_f > 0+   then ["element face " ++ show n_f+        ,"property list uchar int vertex_index"+        ,"property uchar red"+        ,"property uchar green"+        ,"property uchar blue"]+   else []+  ,if n_e > 0+   then ["element edge " ++ show n_e+        ,"property int vertex1"+        ,"property int vertex2"+        ,"property uchar red"+        ,"property uchar green"+        ,"property uchar blue"]+   else []+  ,["end_header"]]++{- | Requires (but does not check) that graph vertices be indexed [0 .. #v - 1]+     Edges are coloured as U8 (red,green,blue) triples.+     It is an error (not checked) for there to be no edges.+     PLY files are zero-indexed.+-}+v3_graph_to_ply_clr :: Int -> T.LBL (Double,Double,Double) (Int,Int,Int) -> [String]+v3_graph_to_ply_clr k (v,e) =+  let v_pp (_,(x,y,z)) = unwords (map (T.double_pp k) [x,y,z])+      e_pp ((i,j),(r,g,b)) = unwords (map show [i,j,r,g,b])+  in concat [ply_header (length v,0,length e)+            ,map v_pp v+            ,map e_pp e]++-- * FACES++-- | Rewrite a set of faces as (vertices,[[v-indices]]).+--   Indices are zero-indexed.+ply_face_set_dat :: Ord n => [([(n,n,n)],(i,i,i))] -> ([(Int,(n,n,n))],[([Int],(i,i,i))])+ply_face_set_dat t =+  let p = nub (sort (concat (map fst t)))+      c = map snd t+      v = zip [0..] p+      f = map (map (flip T.reverse_lookup_err v)) (map fst t)+  in (v,zip f c)++-- | Format a set of coloured faces as an PLY file.+--    (CCW triples of (x,y,z) coordinates, (r,g,b) colour)+--   PLY files are one-indexed.+ply_face_set_fmt :: (Show n, Ord n,Show i) => [([(n,n,n)],(i,i,i))] -> [String]+ply_face_set_fmt t =+  let v_f (_,(x,y,z)) = unwords [show x,show y,show z]+      f_f (ix,(r,g,b)) = unwords (map show (length ix : ix) ++ map show [r,g,b])+      (v,f) = ply_face_set_dat t+  in concat [ply_header (length v,length f,0), map v_f v, map f_f f]++-- | 'writeFile' of 'ply_face_set_fmt'+ply_face_set_store :: (Show n, Ord n,Show i) => FilePath -> [([(n,n,n)],(i,i,i))] -> IO ()+ply_face_set_store fn = writeFile fn . unlines . ply_face_set_fmt
+ Music/Theory/Graph/Type.hs view
@@ -0,0 +1,235 @@+-- | Graph types.+module Music.Theory.Graph.Type where++import Data.Bifunctor {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Data.Graph as G {- containers -}++import qualified Music.Theory.List as T {- hmt -}++-- * Type parameterised graph++-- | (vertices,edges)+type GR t = ([t],[(t,t)])++-- | 'GR' is a functor.+gr_map :: (t -> u) -> GR t -> GR u+gr_map f (v,e) = (map f v,map (bimap f f) e)++-- | (|V|,|E|)+gr_degree :: GR t -> (Int,Int)+gr_degree (v,e) = (length v,length e)++-- | Re-label graph given table.+gr_relabel :: Eq t => [(t,u)] -> GR t -> GR u+gr_relabel tbl (v,e) =+  let get z = T.lookup_err z tbl+  in (map get v,map (\(p,q) -> (get p,get q)) e)++-- | Un-directed edge equality.+--+-- > e_eq_undir (0,1) (1,0) == True+e_eq_undir :: Eq t => (t,t) -> (t,t) -> Bool+e_eq_undir e0 e1 =+  let swap (i,j) = (j,i)+  in e0 == e1 || e0 == swap e1++-- | Sort edge.+--+-- > map e_sort [(0,1),(1,0)] == [(0,1),(0,1)]+e_sort :: Ord t => (t, t) -> (t, t)+e_sort (i,j) = (min i j,max i j)++-- | If (i,j) and (j,i) are both in E delete (j,i) where i < j.+gr_mk_undir :: Ord t => GR t -> GR t+gr_mk_undir (v,e) = (v,nub (sort (map e_sort e)))++-- | List of E to G, derives V from E.+eset_to_gr :: Ord t => [(t,t)] -> GR t+eset_to_gr e =+  let v = sort (nub (concatMap (\(i,j) -> [i,j]) e))+  in (v,e)++-- | Sort v and e.+gr_sort :: Ord t => GR t -> GR t+gr_sort (v,e) = (sort v,sort e)++-- * Int graph++-- | Vertex+type V = Int++-- | Edge+type E = (V,V)++-- | (vertices,edges)+type G = GR V++-- | 'G.Graph' to 'G'.+graph_to_g :: G.Graph -> G+graph_to_g gr = (G.vertices gr,G.edges gr)++-- | 'G' to 'G.Graph'+--+-- > g = ([0,1,2],[(0,1),(0,2),(1,2)])+-- > g == gr_sort (graph_to_g (g_to_graph g))+g_to_graph :: G -> G.Graph+g_to_graph (v,e) = G.buildG (minimum v,maximum v) e++-- | Unlabel graph, make table.+gr_unlabel :: Eq t => GR t -> (G,[(V,t)])+gr_unlabel (v,e) =+  let n = length v+      v' = [0 .. n - 1]+      tbl = zip v' v+      get k = T.reverse_lookup_err k tbl+      e' = map (\(p,q) -> (get p,get q)) e+  in ((v',e'),tbl)++-- | 'g_to_graph' of 'gr_unlabel'.+--+-- > gr = ("abc",[('a','b'),('a','c'),('b','c')])+-- > (g,tbl) = gr_to_graph gr+gr_to_graph :: Eq t => GR t -> (G.Graph,[(V,t)])+gr_to_graph gr =+  let ((v,e),tbl) = gr_unlabel gr+  in (G.buildG (0,length v - 1) e,tbl)++-- * EDG = edge list (zero-indexed)++-- | ((|V|,|E|),[E])+type EDG = ((Int,Int), [E])++-- | Requires V is (0 .. |v| - 1).+edg_to_g :: EDG -> G+edg_to_g ((nv,ne),e) =+  let v = [0 .. nv - 1]+  in if ne /= length e+     then error (show ("edg_to_g",nv,ne,length e))+     else (v,e)++-- | Parse EDG as printed by nauty-listg.+edg_parse :: [String] -> EDG+edg_parse ln =+  let parse_int_list = map read . words+      parse_int_pairs = T.adj2 2 . parse_int_list+      parse_int_pair = T.unlist1_err . parse_int_pairs+  in case ln of+       [m,e] -> (parse_int_pair m,parse_int_pairs e)+       _ -> error "edg_parse"++-- * Adjacencies++-- | Adjacency list+type ADJ t = [(t,[t])]++-- | ADJ to G.+adj_to_gr :: Ord t => ADJ t -> GR t+adj_to_gr adj =+  let e = concatMap (\(i,j) -> zip (repeat i) j) adj+  in eset_to_gr e++-- | G to ADJ.+gr_to_adj :: Ord t => (t -> (t,t) -> Maybe t) -> GR t -> ADJ t+gr_to_adj sel_f (v,e) =+  let f k = (k,sort (mapMaybe (sel_f k) e))+  in filter (\(_,a) -> a /= []) (map f v)++-- | Directed graph to ADJ.+--+-- > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])+-- > r = [(0,[1,3]),(2,[1]),(3,[0])]+-- > gr_to_adj_dir g == r+gr_to_adj_dir :: Ord t => GR t -> ADJ t+gr_to_adj_dir =+  let sel_f k (i,j) = if i == k then Just j else Nothing+  in gr_to_adj sel_f++-- | Un-directed graph to ADJ.+--+-- > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])+-- > gr_to_adj_undir g == [(0,[1,3,3]),(1,[2])]+gr_to_adj_undir :: Ord t => GR t -> ADJ t+gr_to_adj_undir =+  let sel_f k (i,j) =+        if i == k && j >= k+        then Just j+        else if j == k && i >= k+             then Just i+             else Nothing+  in gr_to_adj sel_f++-- | Adjacency matrix, (|v|,mtx)+type ADJ_MTX = (Int,[[Int]])++{- | EDG to ADJ_MTX for un-directed graph.++> e = ((4,3),[(0,3),(1,3),(2,3)])+> edg_to_adj_mtx_undir e == [[0,0,0,1],[0,0,0,1],[0,0,0,1],[1,1,1,0]]++> e = ((4,4),[(0,1),(0,3),(1,2),(2,3)])+> edg_to_adj_mtx_undir e == [[0,1,0,1],[1,0,1,0],[0,1,0,1],[1,0,1,0]]++-}+edg_to_adj_mtx_undir :: EDG -> ADJ_MTX+edg_to_adj_mtx_undir ((nv,_ne),e) =+  let v = [0 .. nv - 1]+      f i j = case find (e_eq_undir (i,j)) e of+                Nothing -> 0+                _ -> 1+  in (nv,map (\i -> map (f i) v) v)++-- * Labels++-- | Labelled graph, distinct vertex and edge labels.+type LBL_GR v v_lbl e_lbl = ([(v,v_lbl)],[((v,v),e_lbl)])++-- | Labelled graph, V/E typed.+type LBL v e = LBL_GR V v e++lbl_degree :: LBL v e -> (Int,Int)+lbl_degree (v,e) = (length v,length e)++-- | Apply /v/ at vertex labels and /e/ at edge labels.+lbl_bimap :: (v -> v') -> (e -> e') -> LBL v e -> LBL v' e'+lbl_bimap v_f e_f (v,e) = (map (fmap v_f) v,map (fmap e_f) e)++v_label :: v -> LBL v e -> V -> v+v_label def (tbl,_) v = fromMaybe def (lookup v tbl)++v_label_err :: LBL v e -> V -> v+v_label_err = v_label (error "v_label")++e_label :: e -> LBL v e -> E -> e+e_label def (_,tbl) e = fromMaybe def (lookup e tbl)++e_label_err :: LBL v e -> E -> e+e_label_err = e_label (error "e_label")++lbl_gr_to_lbl :: Eq v => LBL_GR v v_lbl e_lbl -> LBL v_lbl e_lbl+lbl_gr_to_lbl (v,e) =+  let n = length v+      v' = [0 .. n - 1]+      tbl = zip v' (map fst v)+      get k = T.reverse_lookup_err k tbl+      e' = map (\((p,q),r) -> ((get p,get q),r)) e+  in (zip v' (map snd v),e')++-- > gr_to_lbl ("ab",[('a','b')]) == ([(0,'a'),(1,'b')],[((0,1),('a','b'))])+gr_to_lbl :: Eq t => GR t -> LBL t (t,t)+gr_to_lbl (v,e) = lbl_gr_to_lbl (zip v v,zip e e)++lbl_delete_edge_labels :: LBL v e -> LBL v ()+lbl_delete_edge_labels (v,e) = (v,map (\(x,_) -> (x,())) e)++gr_to_lbl_ :: Eq t => GR t -> LBL t ()+gr_to_lbl_ = lbl_delete_edge_labels . gr_to_lbl++-- | Construct LBL from set of E, derives V from E.+eset_to_lbl :: Ord t => [(t,t)] -> LBL t ()+eset_to_lbl e =+  let v = nub (sort (concatMap (\(i,j) -> [i,j]) e))+      get_ix z = fromMaybe (error "eset_to_lbl") (elemIndex z v)+  in (zip [0..] v, map (\(i,j) -> ((get_ix i,get_ix j),())) e)
Music/Theory/Instrument/Choir.hs view
@@ -1,9 +1,9 @@ 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.List as T {- hmt -} import qualified Music.Theory.Pitch as T {- hmt -} import qualified Music.Theory.Pitch.Name as T {- hmt -} @@ -43,13 +43,9 @@     ,(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+voice_rng tbl v = T.lookup_err v tbl  -- | Lookup 'voice_rng_tbl_std'. voice_rng_std :: Voice -> (T.Pitch,T.Pitch)
Music/Theory/Interval/Barlow_1987.hs view
@@ -4,12 +4,11 @@ module Music.Theory.Interval.Barlow_1987 where  import Data.List {- base -}-import Data.Maybe {- base -} import Data.Ratio {- base -} import Text.Printf {- base -} -import qualified Data.Numbers.Primes as P {- primes -}-+import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Math.Prime as T {- hmt -} import qualified Music.Theory.Tuning as T {- hmt -}  -- | Barlow's /indigestibility/ function for prime numbers.@@ -21,118 +20,49 @@         square n = n * n     in 2 * (square (p' - 1) / p') --- | Generate list of factors of /n/ from /x/.------ > factor P.primes 315 == [3,3,5,7]--- > P.primeFactors 315 == [3,3,5,7]-factor :: Integral a => [a] -> a -> [a]-factor x n =-    case x of-      [] -> undefined-      i:x' -> if n < i-              then [] -- ie. prime factors of 1...-              else if i * i > n-                   then [n]-                   else if rem n i == 0-                        then i : factor x (quot n i)-                        else factor x' n---- | 'factor' /n/ from 'primes'.------ > map prime_factors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]]--- > map P.primeFactors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]]-prime_factors :: Integral a => a -> [a]-prime_factors = factor P.primes---- | Collect number of occurences of each element of a sorted list.------ > multiplicities [1,1,1,2,2,3] == [(1,3),(2,2),(3,1)]-multiplicities :: (Eq a,Integral n) => [a] -> [(a,n)]-multiplicities =-    let f x = case x of-                [] -> undefined-                e:_ -> (e,genericLength x)-    in map f . group---- | 'multiplicities' '.' 'P.primeFactors'.------ > prime_factors_m 315 == [(3,2),(5,1),(7,1)]-prime_factors_m :: Integral a => a -> [(a,a)]-prime_factors_m = multiplicities . P.primeFactors---- | Merging function for 'rational_prime_factors_m'.-merge :: (Ord a,Num b,Eq b) => [(a,b)] -> [(a,b)] -> [(a,b)]-merge p q =-    case (p,q) of-      (_,[]) -> p-      ([],_) -> map (\(i,j) -> (i,-j)) q-      ((a,b):p',(c,d):q') ->-          if a < c-          then (a,b) : merge p' q-          else if a > c-               then (c,-d) : merge p q'-               else if b /= d-                    then (a,b-d) : merge p' q'-                    else merge p' q'---- | Collect the prime factors in a rational number given as a--- numerator/ denominator pair (n,m). Prime factors are listed in--- ascending order with their positive or negative multiplicities,--- depending on whether the prime factor occurs in the numerator or--- the denominator (after cancelling out common factors).------ > rational_prime_factors_m (16,15) == [(2,4),(3,-1),(5,-1)]--- > rational_prime_factors_m (10,9) == [(2,1),(3,-2),(5,1)]--- > rational_prime_factors_m (81,64) == [(2,-6),(3,4)]--- > rational_prime_factors_m (27,16) == [(2,-4),(3,3)]--- > rational_prime_factors_m (12,7) == [(2,2),(3,1),(7,-1)]-rational_prime_factors_m :: Integral b => (b,b) -> [(b,b)]-rational_prime_factors_m (n,m) =-    let n' = prime_factors_m n-        m' = prime_factors_m m-    in merge n' m'---- | Variant of 'rational_prime_factors_m' giving results in a table--- up to the /n/th prime.------ > rational_prime_factors_t 6 (12,7) == [2,1,0,-1,0,0]--- > rational_prime_factors_t 6 (32,9) == [5,-2,0,0,0,0]-rational_prime_factors_t :: Integral b => Int -> (b,b) -> [b]-rational_prime_factors_t n x =-    let r = rational_prime_factors_m x-    in map (\i -> fromMaybe 0 (lookup i r)) (take n P.primes)- -- | Compute the disharmonicity of the interval /(p,q)/ using the -- prime valuation function /pv/. ----- > map (disharmonicity barlow) [(9,10),(8,9)] ~= [12.733333,8.333333]+-- > map (disharmonicity barlow) [(9,10),(8,9)] == ([12 + 11/15,8 + 1/3] :: [Rational]) disharmonicity :: (Integral a,Num b) => (a -> b) -> (a,a) -> b disharmonicity pv (p,q) =-    let n = rational_prime_factors_m (p,q)+    let n = T.rat_prime_factors_m (p,q)     in sum [abs (fromIntegral j) * pv i | (i,j) <- n]  -- | The reciprocal of 'disharmonicity'. ----- > map (harmonicity barlow) [(9,10),(8,9)] ~= [0.078534,0.120000]+-- > map (harmonicity barlow) [(9,10),(8,9),(2,1)] == ([15/191,3/25,1] :: [Rational]) harmonicity :: (Integral a,Fractional b) => (a -> b) -> (a,a) -> b harmonicity pv = recip . disharmonicity pv +harmonicity_m :: (Eq b,Integral a,Fractional b) => (a -> b) -> (a,a) -> Maybe b+harmonicity_m pv = T.recip_m . disharmonicity pv+ -- | Variant of 'harmonicity' with 'Ratio' input.+--+-- > harmonicity_r barlow 1 == 1/0 harmonicity_r :: (Integral a,Fractional b) => (a -> b) -> Ratio a -> b-harmonicity_r pv = harmonicity pv . from_rational---- | 'uncurry' ('%').-to_rational :: Integral a => (a,a) -> Ratio a-to_rational = uncurry (%)+harmonicity_r pv = harmonicity pv . T.rational_nd --- | Make 'numerator' 'denominator' pair of /n/.-from_rational :: Ratio t -> (t, t)-from_rational n = (numerator n,denominator n)+-- | Variant of 'harmonicity_r' with output in (0,100), infinity maps to 100.+harmonicity_r_100 :: (RealFrac b, Integral a) => (a -> b) -> Ratio a -> Int+harmonicity_r_100 pv x =+  case harmonicity_m pv (T.rational_nd x) of+    Nothing -> 100+    Just y -> round (y * 100)  -- | Set of 1. interval size (cents), 2. intervals as product of -- powers of primes, 3. frequency ratio and 4. harmonicity value.-type Table_2_Row = (Double,[Integer],Rational,Double)+type Table_2_Row = (Double,[Int],Rational,Double) +-- | Given ratio /r/ generate 'Table_2_Row'+mk_table_2_row :: Rational -> Table_2_Row+mk_table_2_row r =+  (T.fratio_to_cents r+  ,T.rat_prime_factors_t 6 (T.rational_nd r)+  ,r+  ,harmonicity_r barlow r)+ -- | Table 2 (p.45) -- -- > length (table_2 0.06) == 24@@ -141,43 +71,42 @@ table_2 z =     let g n = n <= 2 && n >= 1         r = nub (sort (filter g [p % q | p <- [1..81],q <- [1..81]]))-        h = map (harmonicity_r barlow) r-        f = (> z) . snd-        k (i,j) = (T.fratio_to_cents i,rational_prime_factors_t 6 (from_rational i),i,j)-    in map k (filter f (zip r h))+        f (_,_,_,h) = h > z+    in filter f (map mk_table_2_row r) --- | Pretty printer for 'Table_2_Row' values.------ > mapM_ (putStrLn . table_2_pp) (table_2 0.06)------ >    0.000 |  0  0  0  0  0  0 |  1:1  | Infinity--- >  111.731 |  4 -1 -1  0  0  0 | 15:16 | 0.076531--- >  182.404 |  1 -2  1  0  0  0 |  9:10 | 0.078534--- >  203.910 | -3  2  0  0  0  0 |  8:9  | 0.120000--- >  231.174 |  3  0  0 -1  0  0 |  7:8  | 0.075269--- >  266.871 | -1 -1  0  1  0  0 |  6:7  | 0.071672--- >  294.135 |  5 -3  0  0  0  0 | 27:32 | 0.076923--- >  315.641 |  1  1 -1  0  0  0 |  5:6  | 0.099338--- >  386.314 | -2  0  1  0  0  0 |  4:5  | 0.119048--- >  407.820 | -6  4  0  0  0  0 | 64:81 | 0.060000--- >  435.084 |  0  2  0 -1  0  0 |  7:9  | 0.064024--- >  498.045 |  2 -1  0  0  0  0 |  3:4  | 0.214286--- >  519.551 | -2  3 -1  0  0  0 | 20:27 | 0.060976--- >  701.955 | -1  1  0  0  0  0 |  2:3  | 0.272727--- >  764.916 |  1 -2  0  1  0  0 |  9:14 | 0.060172--- >  813.686 |  3  0 -1  0  0  0 |  5:8  | 0.106383--- >  884.359 |  0 -1  1  0  0  0 |  3:5  | 0.110294--- >  905.865 | -4  3  0  0  0  0 | 16:27 | 0.083333--- >  933.129 |  2  1  0 -1  0  0 |  7:12 | 0.066879--- >  968.826 | -2  0  0  1  0  0 |  4:7  | 0.081395--- >  996.090 |  4 -2  0  0  0  0 |  9:16 | 0.107143--- > 1017.596 |  0  2 -1  0  0  0 |  5:9  | 0.085227--- > 1088.269 | -3  1  1  0  0  0 |  8:15 | 0.082873--- > 1200.000 |  1  0  0  0  0  0 |  1:2  | 1.000000+{- | Pretty printer for 'Table_2_Row' values.++> mapM_ (putStrLn . table_2_pp) (table_2 0.06)++> >    0.000 |  0  0  0  0  0  0 |  1:1  | Infinity+> >  111.731 |  4 -1 -1  0  0  0 | 15:16 | 0.076531+> >  182.404 |  1 -2  1  0  0  0 |  9:10 | 0.078534+> >  203.910 | -3  2  0  0  0  0 |  8:9  | 0.120000+> >  231.174 |  3  0  0 -1  0  0 |  7:8  | 0.075269+> >  266.871 | -1 -1  0  1  0  0 |  6:7  | 0.071672+> >  294.135 |  5 -3  0  0  0  0 | 27:32 | 0.076923+> >  315.641 |  1  1 -1  0  0  0 |  5:6  | 0.099338+> >  386.314 | -2  0  1  0  0  0 |  4:5  | 0.119048+> >  407.820 | -6  4  0  0  0  0 | 64:81 | 0.060000+> >  435.084 |  0  2  0 -1  0  0 |  7:9  | 0.064024+> >  498.045 |  2 -1  0  0  0  0 |  3:4  | 0.214286+> >  519.551 | -2  3 -1  0  0  0 | 20:27 | 0.060976+> >  701.955 | -1  1  0  0  0  0 |  2:3  | 0.272727+> >  764.916 |  1 -2  0  1  0  0 |  9:14 | 0.060172+> >  813.686 |  3  0 -1  0  0  0 |  5:8  | 0.106383+> >  884.359 |  0 -1  1  0  0  0 |  3:5  | 0.110294+> >  905.865 | -4  3  0  0  0  0 | 16:27 | 0.083333+> >  933.129 |  2  1  0 -1  0  0 |  7:12 | 0.066879+> >  968.826 | -2  0  0  1  0  0 |  4:7  | 0.081395+> >  996.090 |  4 -2  0  0  0  0 |  9:16 | 0.107143+> > 1017.596 |  0  2 -1  0  0  0 |  5:9  | 0.085227+> > 1088.269 | -3  1  1  0  0  0 |  8:15 | 0.082873+> > 1200.000 |  1  0  0  0  0  0 |  1:2  | 1.000000+-} table_2_pp :: Table_2_Row -> String table_2_pp (i,j,k,l) =     let i' = printf "%8.3f" i         j' = unwords (map (printf "%2d") j)-        k' = let (p,q) = from_rational k in printf "%2d:%-2d" q p+        k' = let (p,q) = T.rational_nd k in printf "%2d:%-2d" q p         l' = printf "%1.6f" l     in intercalate " | " [i',j',k',l']
Music/Theory/List.hs view
@@ -3,19 +3,17 @@  import Data.Either {- base -} import Data.Function {- base -}-import qualified Data.IntMap as Map {- containers -} import Data.List {- base -} import Data.Maybe {- base -}-import Data.Tree {- containers -}-import qualified Data.Traversable as T {- base -} +import qualified Data.IntMap as Map {- containers -} import qualified Data.List.Ordered as O {- data-ordlist -} import qualified Data.List.Split as S {- split -}-import qualified Data.List.Split.Internals as S {- split -}+import qualified Data.Tree as Tree {- containers -}  import qualified Control.Monad.Logic as L {- logict -} --- | Data.Vector.slice, ie. starting index (zero-indexed) and number of elements.+-- | 'Data.Vector.slice', ie. starting index (zero-indexed) and number of elements. -- -- > slice 4 5 [1..] == [5,6,7,8,9] slice :: Int -> Int -> [a] -> [a]@@ -33,30 +31,34 @@ bracket :: (a,a) -> [a] -> [a] bracket (l,r) x = l : x ++ [r] -unbracket' :: [a] -> (Maybe a,[a],Maybe a)-unbracket' x =+-- | 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++-- | The first & middle & last elements of a list.+--+-- > map unbracket_el ["","{12}"] == [(Nothing,"",Nothing),(Just '{',"12",Just '}')]+unbracket_el :: [a] -> (Maybe a,[a],Maybe a)+unbracket_el x =     case x of       [] -> (Nothing,[],Nothing)       l:x' -> let (m,r) = separate_last' x' in (Just l,m,r)  -- | The first & middle & last elements of a list. ----- > unbracket "[12]" == Just ('[',"12",']')+-- > map unbracket ["","{12}"] == [Nothing,Just ('{',"12",'}')] unbracket :: [t] -> Maybe (t,[t],t) unbracket x =-    case unbracket' x of+    case unbracket_el x of       (Just l,m,Just r) -> Just (l,m,r)       _ -> Nothing +-- | Erroring variant. unbracket_err :: [t] -> (t,[t],t) unbracket_err = fromMaybe (error "unbracket") . unbracket --- | Variant where brackets are sequences.------ > bracket_l ("<:",":>") "1,2,3" == "<:1,2,3:>"-bracket_l :: ([a],[a]) -> [a] -> [a]-bracket_l (l,r) s = l ++ s ++ r- -- * Split  -- | Relative of 'splitOn', but only makes first separation.@@ -74,20 +76,58 @@                  else f (head rhs : lhs) (tail rhs)     in f [] --- | 'Splitter' comparing single element.-on_elem :: Eq a => a -> S.Splitter a-on_elem e = S.defaultSplitter { S.delimiter = S.Delimiter [(==) e] }+-- | Variant of 'S.splitWhen' that keeps delimiters at left.+--+-- > split_when_keeping_left (== 'r') "rab rcd re rf r" == ["","rab ","rcd ","re ","rf ","r"]+split_when_keeping_left :: (a -> Bool) -> [a] -> [[a]]+split_when_keeping_left = S.split . S.keepDelimsL . S.whenElt --- | Split before the indicated element.+{- | Split before the indicated element, keeping it at the left of the sub-sequence it begins.+     'split_when_keeping_left' of '=='++> split_before 'x' "axbcxdefx" == ["a","xbc","xdef","x"]+> split_before 'x' "xa" == ["","xa"]++> map (flip split_before "abcde") "ae_" == [["","abcde"],["abcd","e"],["abcde"]]+> map (flip break "abcde" . (==)) "ae_" == [("","abcde"),("abcd","e"),("abcde","")]++> split_before 'r' "rab rcd re rf r" == ["","rab ","rcd ","re ","rf ","r"]+-}+split_before :: Eq a => a -> [a] -> [[a]]+split_before x = split_when_keeping_left (== x)++-- | Split before any of the indicated set of delimiters. ----- > split_before 'x' "axbcxdefx" == ["a","xbc","xdef","x"]--- > split_before 'x' "xa" == ["","xa"]+-- > split_before_any ",;" ";a,b,c;d;" == ["",";a",",b",",c",";d",";"]+split_before_any :: Eq a => [a] -> [a] -> [[a]]+split_before_any = S.split . S.keepDelimsL . S.oneOf++-- | Singleton variant of 'S.splitOn'. ----- > map (flip split_before "abcde") "ae_" == [["","abcde"],["abcd","e"],["abcde"]]--- > map (flip break "abcde" . (==)) "ae_" == [("","abcde"),("abcd","e"),("abcde","")]-split_before :: Eq a => a -> [a] -> [[a]]-split_before = S.split . S.keepDelimsL . on_elem+-- > split_on_1 ":" "graph:layout" == Just ("graph","layout")+split_on_1 :: Eq t => [t] -> [t] -> Maybe ([t],[t])+split_on_1 e l =+    case S.splitOn e l of+      [p,q] -> Just (p,q)+      _ -> Nothing +-- | Erroring variant.+split_on_1_err :: Eq t => [t] -> [t] -> ([t],[t])+split_on_1_err e = fromMaybe (error "split_on_1") . split_on_1 e++-- | Split function that splits only once, ie. a variant of 'break'.+--+-- > split1 ' ' "three word sentence" == Just ("three","word sentence")+split1 :: Eq a => a -> [a] -> Maybe ([a],[a])+split1 c l =+    case break (== c) l of+      (lhs,_:rhs) -> Just (lhs,rhs)+      _ -> Nothing++-- | Erroring variant.+split1_err :: (Eq a, Show a) => a -> [a] -> ([a], [a])+split1_err e s = fromMaybe (error (show ("split1",e,s))) (split1 e s)+ -- * Rotate  -- | Generic form of 'rotate_left'.@@ -164,12 +204,19 @@ -- | Variant of 'adj' where the last element has /n/ places but may -- not reach the end of the input sequence. ----- > adj' 3 2 "adjacent" == ["adj","jac","cen"]-adj' :: Int -> Int -> [a] -> [[a]]-adj' n k l =+-- > adj_trunc 4 1 "adjacent" == ["adja","djac","jace","acen","cent"]+-- > adj_trunc 3 2 "adjacent" == ["adj","jac","cen"]+adj_trunc :: Int -> Int -> [a] -> [[a]]+adj_trunc n k l =     let r = take n l-    in if length r == n then r : adj' n k (drop k l) else []+    in if length r == n then r : adj_trunc n k (drop k l) else [] +-- | 'adj_trunc' of 'close' by /n/-1.+--+-- > adj_cyclic_trunc 3 1 "adjacent" == ["adj","dja","jac","ace","cen","ent","nta","tad"]+adj_cyclic_trunc :: Int -> Int -> [a] -> [[a]]+adj_cyclic_trunc n k = adj_trunc n k . close (n - 1)+ -- | Generic form of 'adj2'. genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)] genericAdj2 n l =@@ -186,21 +233,44 @@ adj2 :: Int -> [t] -> [(t,t)] adj2 = genericAdj2 --- | Append first element to end of list.+-- | Append first /n/-elements to end of list. ----- > close [1..3] == [1,2,3,1]-close :: [a] -> [a]-close x =-    case x of-      [] -> []-      e:_ -> x ++ [e]+-- > close 1 [1..3] == [1,2,3,1]+close :: Int -> [a] -> [a]+close k x = x ++ take k x --- | 'adj2' '.' 'close'.+-- | 'adj2' '.' 'close' 1. -- -- > adj2_cyclic 1 [1..3] == [(1,2),(2,3),(3,1)] adj2_cyclic :: Int -> [t] -> [(t,t)]-adj2_cyclic n = adj2 n . close+adj2_cyclic n = adj2 n . close 1 +-- | Adjacent triples.+--+-- > adj3 3 [1..6] == [(1,2,3),(4,5,6)]+adj3 :: Int -> [t] -> [(t,t,t)]+adj3 n l =+  case l of+      p:q:r:_ -> (p,q,r) : adj3 n (drop n l)+      _ -> []++-- | 'adj3' '.' 'close' 2.+--+-- > adj3_cyclic 1 [1..4] == [(1,2,3),(2,3,4),(3,4,1),(4,1,2)]+adj3_cyclic :: Int -> [t] -> [(t,t,t)]+adj3_cyclic n = adj3 n . close 2++{- | Adjacent quadruples.++> adj4 2 [1..8] == [(1,2,3,4),(3,4,5,6),(5,6,7,8)]+> adj4 4 [1..8] == [(1,2,3,4),(5,6,7,8)]+-}+adj4 :: Int -> [t] -> [(t,t,t,t)]+adj4 n l =+  case l of+      p:q:r:s:_ -> (p,q,r,s) : adj4 n (drop n l)+      _ -> []+ -- | Interleave elements of /p/ and /q/. -- -- > interleave [1..3] [4..6] == [1,4,2,5,3,6]@@ -273,26 +343,91 @@ interleave_rotations :: Int -> Int -> [b] -> [b] interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s) -generic_histogram :: (Ord a,Integral i) => [a] -> [(a,i)]-generic_histogram x =-    let g = group (sort x)+-- | 'unzip', apply /f1/ and /f2/ and 'zip'.+rezip :: ([t] -> [u]) -> ([v] -> [w]) -> [(t,v)] -> [(u,w)]+rezip f1 f2 l = let (p,q) = unzip l in zip (f1 p) (f2 q)++-- | Generalised histogram, with equality function for grouping and comparison function for sorting.+generic_histogram_by :: Integral i => (a->a->Bool) -> (Maybe (a->a->Ordering)) -> [a] -> [(a,i)]+generic_histogram_by eq_f cmp_f x =+    let g = groupBy eq_f (maybe x (\f -> sortBy f x) cmp_f)     in zip (map head g) (map genericLength g) -histogram_by :: Ord a => (a -> a -> Bool) -> [a] -> [(a,Int)]-histogram_by f x =-    let g = groupBy f (sort x)-    in zip (map head g) (map length g)+-- | Type specialised 'generic_histogram_by'.+histogram_by :: (a->a->Bool) -> (Maybe (a->a->Ordering)) -> [a] -> [(a,Int)]+histogram_by = generic_histogram_by --- | Count occurences of elements in list.+-- | Count occurences of elements in list, 'histogram_by' of '==' and 'compare'.+generic_histogram :: (Ord a,Integral i) => [a] -> [(a,i)]+generic_histogram = generic_histogram_by (==) (Just compare)++-- | Type specialised 'generic_histogram'.  Elements will be in ascending order. ----- > map histogram ["","hohoh"] == [[],[('h',3),('o',2)]]+-- > map histogram ["","hohoh","yxx"] == [[],[('h',3),('o',2)],[('x',2),('y',1)]] histogram :: Ord a => [a] -> [(a,Int)]-histogram = histogram_by (==)+histogram = generic_histogram +-- | Join two histograms, which must be sorted.+--+-- > histogram_join (zip "ab" [1,1]) (zip "bc" [1,1]) == zip "abc" [1,2,1]+histogram_join :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,Int)]+histogram_join p q =+  let f (e1,n1) (e2,n2) = if e1 == e2 then Just (e1,n1 + n2) else Nothing+  in case (p,q) of+       (_,[]) -> p+       ([],_) -> q+       (p1:p',q1:q') -> case f p1 q1 of+                          Just r -> r : histogram_join p' q'+                          Nothing -> if p1 < q1+                                     then p1 : histogram_join p' q+                                     else q1 : histogram_join p q'++-- | 'foldr' of 'histogram_join'.+--+-- > let f x = zip x (repeat 1) in histogram_merge (map f ["ab","bcd","de"]) == zip "abcde" [1,2,1,2,1]+histogram_merge :: Ord a => [[(a,Int)]] -> [(a,Int)]+histogram_merge = foldr histogram_join []++-- | Given (k,#) histogram where k is enumerable generate filled histogram with 0 for empty k.+--+-- > histogram_fill (histogram "histogram") == zip ['a'..'t'] [1,0,0,0,0,0,1,1,1,0,0,0,1,0,1,0,0,1,1,1]+histogram_fill :: (Ord a, Enum a) => [(a,Int)] -> [(a,Int)]+histogram_fill h =+  let k = map fst h+      e = [minimum k .. maximum k]+      f x = fromMaybe 0 (lookup x h)+  in zip e (map f e)++{- | Given two histograms p & q (sorted by key) make composite+histogram giving for all keys the counts for (p,q).++> r = zip "ABCDE" (zip [4,3,2,1,0] [2,3,4,0,5])+> histogram_composite (zip "ABCD" [4,3,2,1]) (zip "ABCE" [2,3,4,5]) == r+-}+histogram_composite :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,(Int,Int))]+histogram_composite p q =+  case (p,q) of+    ([],_) -> map (\(k,n) -> (k,(0,n))) q+    (_,[]) -> map (\(k,n) -> (k,(n,0))) p+    ((k1,n1):p',(k2,n2):q') -> case compare k1 k2 of+                                 LT -> (k1,(n1,0)) : histogram_composite p' q+                                 EQ -> (k1,(n1,n2)) : histogram_composite p' q'+                                 GT -> (k2,(0,n2)) : histogram_composite p q'++{- | Apply '-' at count of 'histogram_composite', ie. 0 indicates+equal number at p and q, negative indicates more elements at p than+q and positive more elements at q than p.++> histogram_diff (zip "ABCD" [4,3,2,1]) (zip "ABCE" [2,3,4,5]) == zip "ABCDE" [-2,0,2,-1,5]+-}+histogram_diff :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,Int)]+histogram_diff p = map (\(k,(n,m)) -> (k,m - n)) . histogram_composite p++-- | Elements that appear more than once in the input given equality predicate. duplicates_by :: Ord a => (a -> a -> Bool) -> [a] -> [a]-duplicates_by f = map fst . filter (\(_,n) -> n > 1) . histogram_by f+duplicates_by f = map fst . filter (\(_,n) -> n > 1) . histogram_by f (Just compare) --- | Elements that appear more than once in the input.+-- | 'duplicates_by' of '=='. -- -- > map duplicates ["duplicates","redundant"] == ["","dn"] duplicates :: Ord a => [a] -> [a]@@ -341,6 +476,13 @@ filter_halt :: (a -> Bool) -> (a -> Bool) -> [a] -> [a] filter_halt sel end = filter sel . takeWhile end +-- | 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 = map (\e -> if f e then Just e else Nothing)+ -- | Replace all /p/ with /q/ in /s/. -- -- > replace "_x_" "-X-" "an _x_ string" == "an -X- string"@@ -364,31 +506,41 @@  -- * Association lists --- | Equivalent to 'groupBy' '==' 'on' /f/.+-- | Equivalent to 'groupBy' /eq/ 'on' /f/. ----- > let r = [[(1,'a'),(1,'b')],[(2,'c')],[(3,'d'),(3,'e')],[(4,'f')]]--- > in group_on fst (zip [1,1,2,3,3,4] "abcdef") == r+-- > group_by_on (==) snd (zip [0..] "abbc") == [[(0,'a')],[(1,'b'),(2,'b')],[(3,'c')]]+group_by_on :: (x -> x -> Bool) -> (t -> x) -> [t] -> [[t]]+group_by_on eq f = groupBy (eq `on` f)++-- | 'group_by_on' of '=='.+--+-- > r = [[(1,'a'),(1,'b')],[(2,'c')],[(3,'d'),(3,'e')],[(4,'f')]]+-- > group_on fst (zip [1,1,2,3,3,4] "abcdef") == r group_on :: Eq x => (a -> x) -> [a] -> [[a]]-group_on f = map (map snd) . groupBy ((==) `on` fst) . map (\x -> (f x,x))+group_on = group_by_on (==) --- | Given accesors for /key/ and /value/ collate adjacent values.-collate_on_adjacent :: (Eq k,Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]-collate_on_adjacent f g =+-- | Given an equality predicate and accesors for /key/ and /value/ collate adjacent values.+collate_by_on_adjacent :: (k -> k -> Bool) -> (a -> k) -> (a -> v) -> [a] -> [(k,[v])]+collate_by_on_adjacent eq f g =     let h l = case l of-                [] -> error "collate_on_adjacent"+                [] -> error "collate_by_on_adjacent"                 l0:_ -> (f l0,map g l)-    in map h . group_on f+    in map h . group_by_on eq f +-- | 'collate_by_on_adjacent' of '=='+collate_on_adjacent :: Eq k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]+collate_on_adjacent = collate_by_on_adjacent (==)+ -- | 'collate_on_adjacent' of 'fst' and 'snd'. -- -- > collate_adjacent (zip "TDD" "xyz") == [('T',"x"),('D',"yz")]-collate_adjacent :: Ord a => [(a,b)] -> [(a,[b])]+collate_adjacent :: Eq a => [(a,b)] -> [(a,[b])] collate_adjacent = collate_on_adjacent fst snd  -- | 'sortOn' prior to 'collate_on_adjacent'. ----- > let r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")]--- > in collate_on fst snd (zip "ABCBCD" "abcdef") == r+-- > r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")]+-- > collate_on fst snd (zip "ABCBCD" "abcdef") == r collate_on :: Ord k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])] collate_on f g = collate_on_adjacent f g . sortOn f @@ -411,6 +563,34 @@ with_key :: k -> [v] -> [(k,v)] with_key h = zip (repeat h) +-- | Left biased merge of association lists /p/ and /q/.+--+-- > assoc_merge [(5,"a"),(3,"b")] [(5,"A"),(7,"C")] == [(5,"a"),(3,"b"),(7,"C")]+assoc_merge :: Eq k => [(k,v)] -> [(k,v)] -> [(k,v)]+assoc_merge p q =+    let p_k = map fst p+        q' = filter ((`notElem` p_k) . fst) q+    in p ++ q'++-- | Keys are in ascending order, the entry retrieved is the rightmose with+--   a key less than or equal to the key requested.+--   If the key requested is less than the initial key, or the list is empty, returns 'Nothing'.+--+-- > let m = [(1,'a'),(4,'x'),(4,'b'),(5,'c')]+-- > mapMaybe (ord_map_locate m) [1 .. 6] == [(1,'a'),(1,'a'),(1,'a'),(4,'b'),(5,'c'),(5,'c')]+-- > ord_map_locate m 0 == Nothing+ord_map_locate :: Ord k => [(k,v)] -> k -> Maybe (k,v)+ord_map_locate mp i =+    let f (k0,v0) xs =+          case xs of+            [] -> if i >= k0 then Just (k0,v0) else error "ord_map_locate?"+            ((k1,v1):xs') -> if i >= k0 && i < k1 then Just (k0,v0) else f (k1,v1) xs'+    in case mp of+         [] -> Nothing+         (k0,v0):mp' -> if i < k0 then Nothing else f (k0,v0) mp'++-- * Δ+ -- | Intervals to values, zero is /n/. -- -- > dx_d 5 [1,2,3] == [5,6,8,11]@@ -428,9 +608,11 @@       e:r -> (e,reverse r)       _ -> error "dx_d'" --- | Apply flip of /f/ between elements of /l/.+-- | Integration with /f/, ie. apply flip of /f/ between elements of /l/. -- -- > d_dx_by (,) "abcd" == [('b','a'),('c','b'),('d','c')]+-- > d_dx_by (-) [0,2,4,1,0] == [2,2,-3,-1]+-- > d_dx_by (-) [2,3,0,4,1] == [1,-3,4,-3] d_dx_by :: (t -> t -> u) -> [t] -> [u] d_dx_by f l = if null l then [] else zipWith f (tail l) l @@ -444,10 +626,8 @@ -- | Elements of /p/ not in /q/. -- -- > [1,2,3] `difference` [1,2] == [3]-difference :: (Eq a) => [a] -> [a] -> [a]-difference p q =-    let f e = e `notElem` q-    in filter f p+difference :: Eq a => [a] -> [a] -> [a]+difference p q = filter (`notElem` q) p  -- | Is /p/ a subset of /q/, ie. is 'intersect' of /p/ and /q/ '==' /p/. --@@ -464,19 +644,27 @@ -- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'. -- -- > subsequence [1,2] [1,2,3] == True-subsequence :: (Eq a) => [a] -> [a] -> Bool+subsequence :: Eq a => [a] -> [a] -> Bool subsequence = isInfixOf +-- | Erroring variant of 'findIndex'.+findIndex_err :: (a -> Bool) -> [a] -> Int+findIndex_err f = fromMaybe (error "findIndex?") . findIndex f++-- | Erroring variant of 'elemIndex'.+elemIndex_err :: Eq a => a -> [a] -> Int+elemIndex_err x = fromMaybe (error "ix_of") . elemIndex x+ -- | Variant of 'elemIndices' that requires /e/ to be unique in /p/. -- -- > elem_index_unique 'a' "abcda" == undefined-elem_index_unique :: (Eq a) => a -> [a] -> Int+elem_index_unique :: Eq a => a -> [a] -> Int elem_index_unique e p =     case elemIndices e p of       [i] -> i       _ -> error "elem_index_unique" --- | Lookup that errors and prints message.+-- | Lookup that errors and prints message and key. lookup_err_msg :: (Eq k,Show k) => String -> k -> [(k,v)] -> v lookup_err_msg err k = fromMaybe (error (err ++ ": " ++ show k)) . lookup k @@ -488,13 +676,32 @@ lookup_def :: Eq k => k -> v -> [(k,v)] -> v lookup_def k d = fromMaybe d . lookup k +-- | If /l/ is empty 'Nothing', else 'Just' /l/.+non_empty :: [t] -> Maybe [t]+non_empty l = if null l then Nothing else Just l++-- | Variant on 'filter' that selects all matches.+--+-- > lookup_set 1 (zip [1,2,3,4,1] "abcde") == Just "ae"+lookup_set :: Eq k => k -> [(k,v)] -> Maybe [v]+lookup_set k = non_empty . map snd . filter ((== k) . fst)++-- | Erroring variant.+lookup_set_err :: Eq k => k -> [(k,v)] -> [v]+lookup_set_err k = fromMaybe (error "lookup_set?") . lookup_set k+ -- | Reverse lookup. -- -- > reverse_lookup 'c' [] == Nothing--- > reverse_lookup 'c' (zip [0..4] ['a'..]) == Just 2-reverse_lookup :: Eq b => b -> [(a,b)] -> Maybe a+-- > reverse_lookup 'b' (zip [1..] ['a'..]) == Just 2+-- > lookup 2 (zip [1..] ['a'..]) == Just 'b'+reverse_lookup :: Eq v => v -> [(k,v)] -> Maybe k reverse_lookup k = fmap fst . find ((== k) . snd) +-- | Erroring variant.+reverse_lookup_err :: Eq v => v -> [(k,v)] -> k+reverse_lookup_err k = fromMaybe (error "reverse_lookup") . reverse_lookup k+ {- reverse_lookup :: Eq b => b -> [(a,b)] -> Maybe a reverse_lookup key ls =@@ -503,55 +710,70 @@       (x,y):ls' -> if key == y then Just x else reverse_lookup key ls' -} +-- | Erroring variant of 'find'.+find_err :: (t -> Bool) -> [t] -> t+find_err f = fromMaybe (error "find") . find f  -- | Basis of 'find_bounds_scl', indicates if /x/ is to the left or--- right of the list, and it to the right whether equal or not.+-- right of the list, and if to the right whether equal or not. -- 'Right' values will be correct if the list is not ascending, -- however 'Left' values only make sense for ascending ranges. ----- > map (find_bounds' compare [(0,1),(1,2)]) [-1,0,1,2,3]-find_bounds' :: (t -> s -> Ordering) -> [(t,t)] -> s -> Either ((t,t),Ordering) (t,t)-find_bounds' f l x =+-- > map (find_bounds_cmp compare [(0,1),(1,2)]) [-1,0,1,2,3]+find_bounds_cmp :: (t -> s -> Ordering) -> [(t,t)] -> s -> Either ((t,t),Ordering) (t,t)+find_bounds_cmp f l x =     let g (p,q) = f p x /= GT && f q x == GT     in case l of-         [] -> error "find_bounds': nil"+         [] -> error "find_bounds_cmp: nil"          [(p,q)] -> if g (p,q) then Right (p,q) else Left ((p,q),f q x)          (p,q):l' -> if f p x == GT                      then Left ((p,q),GT)-                     else if g (p,q) then Right (p,q) else find_bounds' f l' x+                     else if g (p,q) then Right (p,q) else find_bounds_cmp f l' x -decide_nearest' :: Ord o => (p -> o) -> (p,p) -> p-decide_nearest' f (p,q) = if f p < f q then p else q+decide_nearest_f :: Ord o => Bool -> (p -> o) -> (p,p) -> ((x,x) -> x)+decide_nearest_f bias_left f (p,q) =+  case compare (f p) (f q) of+    LT -> fst+    EQ -> if bias_left then fst else snd+    GT -> snd --- | Decide if value is nearer the left or right value of a range.-decide_nearest :: (Num o,Ord o) => o -> (o, o) -> o-decide_nearest x = decide_nearest' (abs . (x -))+-- | Decide if value is nearer the left or right value of a range, return 'fst' or 'snd'.+--+-- > (decide_nearest True 2 (1,3)) ("left","right") == "left"+decide_nearest :: (Num o,Ord o) => Bool -> o -> (o,o) -> ((x,x) -> x)+decide_nearest bias_left x = decide_nearest_f bias_left (abs . (x -)) +-- | /sel_f/ gets comparison key from /t/.+find_nearest_by :: (Ord n,Num n) => (t -> n) -> Bool -> [t] -> n -> t+find_nearest_by sel_f bias_left l x =+  let cmp_f i j = compare (sel_f i) j+  in case find_bounds_cmp cmp_f (adj2 1 l) x of+       Left ((p,_),GT) -> p+       Left ((_,q),_) -> q+       Right (p,q) -> (decide_nearest bias_left x (sel_f p,sel_f q)) (p,q)+ -- | Find the number that is nearest the requested value in an -- ascending list of numbers. ----- > map (find_nearest_err [0,3.5,4,7]) [-1,1,3,5,7,9] == [0,0,3.5,4,7,7]-find_nearest_err :: (Num n,Ord n) => [n] -> n -> n-find_nearest_err l x =-    case find_bounds' compare (adj2 1 l) x of-      Left ((p,_),GT) -> p-      Left ((_,q),_) -> q-      Right (p,q) -> decide_nearest x (p,q)+-- > map (find_nearest_err True [0,3.5,4,7]) [-1,1,3,5,7,9] == [0,0,3.5,4,7,7]+find_nearest_err :: (Num n,Ord n) => Bool -> [n] -> n -> n+find_nearest_err = find_nearest_by id -find_nearest :: (Num n,Ord n) => [n] -> n -> Maybe n-find_nearest l x = if null l then Nothing else Just (find_nearest_err l x)+find_nearest :: (Num n,Ord n) => Bool -> [n] -> n -> Maybe n+find_nearest bias_left l x = if null l then Nothing else Just (find_nearest_err bias_left l x)  -- | Basis of 'find_bounds'.  There is an option to consider the last -- element specially, and if equal to the last span is given.+--+-- scl=special-case-last find_bounds_scl :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t) find_bounds_scl scl f l x =-    case find_bounds' f l x of+    case find_bounds_cmp f l x of          Right r -> Just r          Left (r,EQ) -> if scl then Just r else Nothing          _ -> Nothing --- | Find adjacent elements of list that bound element under given--- comparator.+-- | Find adjacent elements of list that bound element under given comparator. -- -- > let {f = find_bounds True compare [1..5] -- >     ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]}@@ -593,6 +815,27 @@ take_while_right :: (a -> Bool) -> [a] -> [a] take_while_right p = reverse . takeWhile p . reverse +-- | Variant of 'take' that allows 'Nothing' to indicate the complete list.+--+-- > maybe_take (Just 5) [1 .. ] == [1 .. 5]+-- > maybe_take Nothing [1 .. 9] == [1 .. 9]+maybe_take :: Maybe Int -> [a] -> [a]+maybe_take n l = maybe l (flip take l) n++{- | Take until /f/ is true.  This is not the same as 'not' at+     'takeWhile' because it keeps the last element. It is an error+     if the predicate never succeeds.++> take_until (== 'd') "tender" == "tend"+> takeWhile (not . (== 'd')) "tend" == "ten"+> take_until (== 'd') "seven" == undefined+-}+take_until :: (a -> Bool) -> [a] -> [a]+take_until f l =+  case l of+    [] -> error "take_until?"+    e:l' -> if f e then [e] else e : take_until f l'+ -- | Apply /f/ at first element, and /g/ at all other elements. -- -- > at_head negate id [1..5] == [-1,2,3,4,5]@@ -700,6 +943,12 @@ all_eq :: Eq n => [n] -> Bool all_eq = (== 1) . length . nub +-- | 'nubBy' '==' 'on' /f/.+--+-- > nub_on snd (zip "ABCD" "xxyy") == [('A','x'),('C','y')]+nub_on :: Eq b => (a -> b) -> [a] -> [a]+nub_on f = nubBy ((==) `on` f)+ -- | 'group_on' of 'sortOn'. -- -- > let r = [[('1','a'),('1','c')],[('2','d')],[('3','b'),('3','e')]]@@ -714,6 +963,12 @@ mcons :: Maybe a -> [a] -> [a] mcons e l = maybe l (:l) e +-- | Cons onto end of list.+--+-- > snoc 4 [1,2,3] == [1,2,3,4]+snoc :: a -> [a] -> [a]+snoc e l = l ++ [e]+ -- * Ordering  -- | Comparison function type.@@ -726,6 +981,10 @@       EQ -> g p q       r -> r +-- | 'compare' 'on' of 'two_stage_compare'+two_stage_compare_on :: (Ord i, Ord j) => (t -> i) -> (t -> j) -> t -> t -> Ordering+two_stage_compare_on f g = two_stage_compare (compare `on` f) (compare `on` g)+ -- | Sequence of comparison functions, continue comparing until not EQ. -- -- > compare (1,0) (0,1) == GT@@ -738,6 +997,10 @@                 EQ -> n_stage_compare l' p q                 r -> r +-- | 'compare' 'on' of 'two_stage_compare'+n_stage_compare_on :: Ord i => [t -> i] -> t -> t -> Ordering+n_stage_compare_on l = n_stage_compare (map (compare `on`) l)+ -- | Sort sequence /a/ based on ordering of sequence /b/. -- -- > sort_to "abc" [1,3,2] == "acb"@@ -747,18 +1010,26 @@  -- | '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+-- > sort_to_rev [1,4,2,3,5] "adbce" == "abcde"+sort_to_rev :: Ord i => [i] -> [e] -> [e]+sort_to_rev = 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))+sort_by_two_stage :: Compare_F a -> Compare_F a -> [a] -> [a]+sort_by_two_stage f g = sortBy (two_stage_compare f g)  -- | 'sortBy' of 'n_stage_compare'.-sort_by_n_stage :: Ord b => [a -> b] -> [a] -> [a]-sort_by_n_stage f = sortBy (n_stage_compare (map (compare `on`) f))+sort_by_n_stage :: [Compare_F a] -> [a] -> [a]+sort_by_n_stage f = sortBy (n_stage_compare f) +-- | 'sortBy' of 'two_stage_compare_on'.+sort_by_two_stage_on :: (Ord b,Ord c) => (a -> b) -> (a -> c) -> [a] -> [a]+sort_by_two_stage_on f g = sortBy (two_stage_compare_on f g)++-- | 'sortBy' of 'n_stage_compare_on'.+sort_by_n_stage_on :: Ord b => [a -> b] -> [a] -> [a]+sort_by_n_stage_on f = sortBy (n_stage_compare_on f)+ -- | Given a comparison function, merge two ascending lists. -- -- > mergeBy compare [1,3,5] [2,4] == [1..5]@@ -800,6 +1071,8 @@ > in merge_by_resolve left cmp p q == left_r && >    merge_by_resolve right cmp p q == right_r +> merge_by_resolve (\x _ -> x) (compare `on` fst) [(0,'A'),(1,'B'),(4,'E')] (zip [1..] "bcd")+ -} merge_by_resolve :: (a -> a -> a) -> Compare_F a -> [a] -> [a] -> [a] merge_by_resolve jn cmp =@@ -813,21 +1086,35 @@                                GT -> r : recur p q'     in recur --- | First non-ascending pair of elements.-find_non_ascending :: (a -> a -> Ordering) -> [a] -> Maybe (a,a)-find_non_ascending cmp xs =+-- | Merge two sorted (ascending) sequences.+--   Where elements compare equal, select element from left input.+--+-- > asc_seq_left_biased_merge_by (compare `on` fst) [(0,'A'),(1,'B'),(4,'E')] (zip [1..] "bcd")+asc_seq_left_biased_merge_by :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+asc_seq_left_biased_merge_by = merge_by_resolve (\x _ -> x)++-- | Find the first two adjacent elements for which /f/ is True.+--+-- > find_adj (>) [1,2,3,3,2,1] == Just (3,2)+-- > find_adj (>=) [1,2,3,3,2,1] == Just (3,3)+find_adj :: (a -> a -> Bool) -> [a] -> Maybe (a,a)+find_adj f xs =     case xs of-      p:q:xs' -> if cmp p q == GT then Just (p,q) else find_non_ascending cmp (q:xs')+      p:q:xs' -> if f p q then Just (p,q) else find_adj f (q:xs')       _ -> Nothing --- | 'isNothing' of 'find_non_ascending'.-is_ascending_by :: (a -> a -> Ordering) -> [a] -> Bool-is_ascending_by cmp = isNothing . find_non_ascending cmp---- | 'is_ascending_by' 'compare'.+-- | 'find_adj' of '>='+--+-- > filter is_ascending (words "A AA AB ABB ABC ABA") == words "A AB ABC" is_ascending :: Ord a => [a] -> Bool-is_ascending = is_ascending_by compare+is_ascending = isNothing . find_adj (>=) +-- | 'find_adj' of '>'+--+-- > filter is_non_descending (words "A AA AB ABB ABC ABA") == ["A","AA","AB","ABB","ABC"]+is_non_descending :: Ord a => [a] -> Bool+is_non_descending = isNothing . find_adj (>)+ -- | Variant of `elem` that operates on a sorted list, halting. --   This is 'O.member'. --@@ -852,6 +1139,26 @@                            else recur (k + 1) l'     in recur 0 +-- | 'zipWith' variant that extends shorter side using given value.+zip_with_ext :: t -> u -> (t -> u -> v) -> [t] -> [u] -> [v]+zip_with_ext i j f p q =+  case (p,q) of+    ([],_) -> zipWith f (repeat i) q+    (_,[]) -> zipWith f p (repeat j)+    (x:p',y:q') -> f x y : zip_with_ext i j f p' q'++{- | 'zip_with_ext' of ','++> let f = zip_ext 'i' 'j'+> f "" "" == []+> f "p" "" == zip "p" "j"+> f "" "q" == zip "i" "q"+> f "pp" "q" == zip "pp" "qj"+> f "p" "qq" == zip "pi" "qq"+-}+zip_ext :: t -> u -> [t] -> [u] -> [(t,u)]+zip_ext i j = zip_with_ext i j (,)+ -- | Keep right variant of 'zipWith', where unused rhs values are returned. -- -- > zip_with_kr (,) [1..3] ['a'..'e'] == ([(1,'a'),(2,'b'),(3,'c')],"de")@@ -900,29 +1207,39 @@                                else (m,e) : recur (n + 1) x'     in recur l +-- | Variant with default value for empty input list case.+minimumBy_or :: t -> (t -> t -> Ordering) -> [t] -> t+minimumBy_or p f q = if null q then p else minimumBy f q+ -- | 'minimum' and 'maximum' in one pass. ----- > minmax "minimumandmaximum" == ('a','x')+-- > minmax "minmax" == ('a','x') minmax :: Ord t => [t] -> (t,t) minmax inp =     case inp of       [] -> error "minmax: null"       x:xs -> let mm p (l,r) = (min p l,max p r) in foldr mm (x,x) xs --- * Bimap---- | Apply /f/ to both elements of a two-tuple, ie. 'bimap' /f/ /f/.-bimap1 :: (t -> u) -> (t,t) -> (u,u)-bimap1 f (p,q) = (f p,f q)- -- | Append /k/ to the right of /l/ until result has /n/ places.+--   Truncates long input lists. -- -- > map (pad_right '0' 2 . return) ['0' .. '9'] -- > pad_right '0' 12 "1101" == "110100000000" -- > map (pad_right ' '3) ["S","E-L"] == ["S  ","E-L"]+-- > pad_right '!' 3 "truncate" == "tru" pad_right :: a -> Int -> [a] -> [a] pad_right k n l = take n (l ++ repeat k) +-- | Variant that errors if the input list has more than /n/ places.+--+-- > map (pad_right_err '!' 3) ["x","xy","xyz","xyz!"]+pad_right_err :: t -> Int -> [t] -> [t]+pad_right_err k n l = if length l > n then error "pad_right_err?" else pad_right k n l++-- > pad_right_no_truncate '!' 3 "truncate" == "truncate"+pad_right_no_truncate :: a -> Int -> [a] -> [a]+pad_right_no_truncate k n l = if length l > n then l else pad_right k n l+ -- | Append /k/ to the left of /l/ until result has /n/ places. -- -- > map (pad_left '0' 2 . return) ['0' .. '9']@@ -999,26 +1316,39 @@ -- -- > let t = Node 0 [Node 1 [Node 2 [],Node 3 []],Node 4 []] -- > putStrLn $ drawTree (fmap show t)--- > let u = (adopt_shape (\_ x -> x) "abcde" t)+-- > let (_,u) = adopt_shape (\_ x -> x) "abcde" t -- > putStrLn $ drawTree (fmap return u)-adopt_shape :: T.Traversable t => (a -> b -> c) -> [b] -> t a -> t c+adopt_shape :: Traversable t => (a -> b -> c) -> [b] -> t a -> ([b],t c) adopt_shape jn l =     let f (i:j) k = (j,jn k i)         f [] _ = error "adopt_shape: rhs ends"-    in snd . T.mapAccumL f l+    in mapAccumL f l --- | Variant of 'adopt_shape' that considers only 'Just' elements at 'Traversable'.+-- | Two-level variant of 'adopt_shape'. ----- > let {s = "a(b(cd)ef)ghi"--- >     ;t = group_tree (begin_end_cmp_eq '(' ')') s}--- > in adopt_shape_m (,) [1..13] t-adopt_shape_m :: T.Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> t (Maybe c)+-- > adopt_shape_2 (,) [0..4] (words "a bc d") == ([4],[[('a',0)],[('b',1),('c',2)],[('d',3)]])+adopt_shape_2 :: (Traversable t,Traversable u) => (a -> b -> c) -> [b] -> t (u a) -> ([b],t (u c))+adopt_shape_2 jn l = mapAccumL (adopt_shape jn) l++-- | Two-level variant of 'zip' [1..]+--+-- > list_number_2 ["number","list","2"]+list_number_2 :: [[x]] -> [[(Int,x)]]+list_number_2 = snd . adopt_shape_2 (flip (,)) [1..]++{- | Variant of 'adopt_shape' that considers only 'Just' elements at 'Traversable'.++> let s = "a(b(cd)ef)ghi"+> let t = group_tree (begin_end_cmp_eq '(' ')') s+> adopt_shape_m (,) [1..13] t+-}+adopt_shape_m :: Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> ([b],t (Maybe c)) adopt_shape_m jn l =     let f (i:j) k = case k of                       Nothing -> (i:j,Nothing)                       Just k' -> (j,Just (jn k' i))         f [] _ = error "adopt_shape_m: rhs ends"-    in snd . T.mapAccumL f l+    in mapAccumL f l  -- * Tree @@ -1026,20 +1356,20 @@ closes a group, and 'EQ' continues current group, construct tree from list. -> let {l = "a {b {c d} e f} g h i"->     ;t = group_tree ((==) '{',(==) '}') l}-> in catMaybes (flatten t) == l+> let l = "a {b {c d} e f} g h i"+> let t = group_tree ((==) '{',(==) '}') l+> catMaybes (flatten t) == l  > let {d = putStrLn . drawTree . fmap show} > in d (group_tree ((==) '(',(==) ')') "a(b(cd)ef)ghi")  -}-group_tree :: (a -> Bool,a -> Bool) -> [a] -> Tree (Maybe a)+group_tree :: (a -> Bool,a -> Bool) -> [a] -> Tree.Tree (Maybe a) group_tree (open_f,close_f) =-    let unit e = Node (Just e) []-        nil = Node Nothing []-        insert_e (Node t l) e = Node t (e:l)-        reverse_n (Node t l) = Node t (reverse l)+    let unit e = Tree.Node (Just e) []+        nil = Tree.Node Nothing []+        insert_e (Tree.Node t l) e = Tree.Node t (e:l)+        reverse_n (Tree.Node t l) = Tree.Node t (reverse l)         do_push (r,z) e =             case z of               h:z' -> (r,insert_e h (unit e) : z')@@ -1052,7 +1382,7 @@               [] -> (r,z)         go st x =             case x of-              [] -> Node Nothing (reverse (fst st))+              [] -> Tree.Node Nothing (reverse (fst st))               e:x' -> if open_f e                       then go (do_push (do_open st) e) x'                       else if close_f e@@ -1069,16 +1399,21 @@ remove_ix :: Int -> [a] -> [a] remove_ix k l = let (p,q) = splitAt k l in p ++ tail q +-- | Select or remove elements at set of indices. operate_ixs :: Bool -> [Int] -> [a] -> [a] operate_ixs mode k =     let sel = if mode then notElem else elem         f (n,e) = if n `sel` k then Nothing else Just e     in mapMaybe f . zip [0..] +-- | Select elements at set of indices.+-- -- > select_ixs [1,3] "select" == "ee" select_ixs :: [Int] -> [a] -> [a] select_ixs = operate_ixs True +-- | Remove elements at set of indices.+-- -- > remove_ixs [1,3,5] "remove" == "rmv" remove_ixs :: [Int] -> [a] -> [a] remove_ixs = operate_ixs False@@ -1090,6 +1425,43 @@ replace_ix f i p =     let (q,r:s) = splitAt i p     in q ++ (f r : s)++-- | List equality, ignoring indicated indices.+--+-- > list_eq_ignoring_indices [3,5] "abcdefg" "abc.e.g" == True+list_eq_ignoring_indices :: (Eq t,Integral i) => [i] -> [t] -> [t] -> Bool+list_eq_ignoring_indices x =+  let f n p q =+        case (p,q) of+          ([],[]) -> True+          ([],_) -> False+          (_,[]) -> False+          (p1:p',q1:q') -> if n `elem` x || p1 == q1+                           then f (n + 1) p' q'+                           else False+  in f 0++-- | Edit list to have /v/ at indices /k/.+--   Replacement assoc-list must be ascending.+--   All replacements must be in range.+--+-- > list_set_indices [(2,'C'),(4,'E')] "abcdefg" == "abCdEfg"+-- > list_set_indices [] "abcdefg" == "abcdefg"+-- > list_set_indices [(9,'I')] "abcdefg" == undefined+list_set_indices :: (Eq ix, Num ix) => [(ix,t)] -> [t] -> [t]+list_set_indices =+  let f n r l =+        case (r,l) of+          ([],_) -> l+          (_,[]) -> error "list_set_indices: out of range?"+          ((k,v):r',l0:l') -> if n == k+                              then v : f (n + 1) r' l'+                              else l0 : f (n + 1) r l'+  in f 0++-- | Variant of 'list_set_indices' with one replacement.+list_set_ix :: (Eq t, Num t) => t -> a -> [a] -> [a]+list_set_ix k v = list_set_indices [(k,v)]  -- | Cyclic indexing function. --
Music/Theory/Math.hs view
@@ -1,15 +1,28 @@ -- | Math functions. module Music.Theory.Math where +import Data.List {- base -} import Data.Maybe {- base -} import Data.Ratio {- base -}-import Numeric {- base -}  import qualified Music.Theory.Math.Convert as T --- | Real (alias for 'Double').-type R = Double+-- | 'mod' 5.+mod5 :: Integral i => i -> i+mod5 n = n `mod` 5 +-- | 'mod' 7.+mod7 :: Integral i => i -> i+mod7 n = n `mod` 7++-- | 'mod' 12.+mod12 :: Integral i => i -> i+mod12 n = n `mod` 12++-- | 'mod' 16.+mod16 :: Integral i => i -> i+mod16 n = n `mod` 16+ -- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html> -- -- > integral_and_fractional_parts 1.5 == (1,0.5)@@ -26,7 +39,7 @@ -- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html> -- -- > import Sound.SC3.Plot {- hsc3-plot -}--- > plotTable1 (map fractional_part [-2.0,-1.99 .. 2.0])+-- > plot_p1_ln [map fractional_part [-2.0,-1.99 .. 2.0]] fractional_part :: RealFrac a => a -> a fractional_part = snd . integer_and_fractional_parts @@ -46,10 +59,18 @@ real_round_int :: Real r => r -> Int real_round_int = real_round +-- | Type-specialised 'fromIntegral'+from_integral_to_int :: Integral i => i -> Int+from_integral_to_int = fromIntegral++-- | Type-specialised 'id'+int_id :: Int -> Int+int_id = id+ -- | Is /r/ zero to /k/ decimal places. -- -- > map (flip zero_to_precision 0.00009) [4,5] == [True,False]--- > zero_to_precision 4 1.00009 == False+-- > map (zero_to_precision 4) [0.00009,1.00009] == [True,False] zero_to_precision :: Real r => Int -> r -> Bool zero_to_precision k r = real_floor_int (r * (fromIntegral ((10::Int) ^ k))) == 0 @@ -61,34 +82,14 @@  -- | <http://reference.wolfram.com/mathematica/ref/SawtoothWave.html> ----- > plotTable1 (map sawtooth_wave [-2.0,-1.99 .. 2.0])+-- > plot_p1_ln [map sawtooth_wave [-2.0,-1.99 .. 2.0]] sawtooth_wave :: RealFrac a => a -> a sawtooth_wave n = n - floor_f 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+-- > map rational_simplifies [(2,3),(4,6),(5,7)] == [False,True,False] rational_simplifies :: Integral a => (a,a) -> Bool rational_simplifies (n,d) = gcd n d /= 1 @@ -104,48 +105,15 @@ rational_whole_err :: Integral a => Ratio a -> a rational_whole_err = fromMaybe (error "rational_whole") . rational_whole --- | Show rational to /n/ decimal places.------ > let r = approxRational pi 1e-100--- > r == 884279719003555 / 281474976710656--- > show_rational_decimal 12 r == "3.141592653590"-show_rational_decimal :: Int -> Rational -> String-show_rational_decimal n r =-    let d = round (abs r * 10^n)-        s = show (d :: Integer)-        s' = replicate (n - length s + 1) '0' ++ s-        (h, f) = splitAt (length s' - n) s'-    in  (if r < 0 then "-" else "") ++ h ++ "." ++ f---- | Variant of 'showFFloat'.  The 'Show' instance for floats resorts--- to exponential notation very readily.------ > [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 ""---- | Show /r/ as float to /k/ places.-real_pp :: Real t => Int -> t -> String-real_pp k t = showFFloat (Just k) (T.real_to_double t) ""---- | Type specialised 'realfloat_pp'.-float_pp :: Int -> Float -> String-float_pp = realfloat_pp---- | Type specialised 'realfloat_pp'.-double_pp :: Int -> Double -> String-double_pp = realfloat_pp+-- | Sum of numerator & denominator.+ratio_nd_sum :: Num a => Ratio a -> a+ratio_nd_sum r = numerator r + denominator r --- | Show /only/ positive and negative values, always with sign.+-- | Is /n/ a whole (integral) value. ----- > 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+-- > map real_is_whole [-1.0,-0.5,0.0,0.5,1.0] == [True,False,True,False,True]+real_is_whole :: Real n => n -> Bool+real_is_whole = (== 1) . denominator . toRational  -- | 'fromInteger' . 'floor'. floor_f :: (RealFrac a, Num b) => a -> b@@ -158,6 +126,13 @@ round_to :: RealFrac n => n -> n -> n round_to a b = if a == 0 then b else floor_f ((b / a) + 0.5) * a +-- | Variant of 'recip' that checks input for zero.+--+-- > map recip [1,1/2,0,-1]+-- > map recip_m [1,1/2,0,-1] == [Just 1,Just 2,Nothing,Just (-1)]+recip_m :: (Eq a, Fractional a) => a -> Maybe a+recip_m x = if x == 0 then Nothing else Just (recip x)+ -- * One-indexed  -- | One-indexed 'mod' function.@@ -205,3 +180,101 @@ -- | [p,q) [0,1) = {x | 0 ≤ x < 1} in_right_half_open_interval :: Ord a => (a, a) -> a -> Bool in_right_half_open_interval (p,q) n = p <= n && n < q++-- | Calculate /n/th root of /x/.+--+-- > 12 `nth_root` 2 == 1.0594630943592953+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)+        eq = uncurry (==)+    in fst (until eq f (x, x/n))++-- | Arithmetic mean (average) of a list.+--+-- > map arithmetic_mean [[-3..3],[0..5],[1..5],[3,5,7],[7,7],[3,9,10,11,12]] == [0,2.5,3,5,7,9]+arithmetic_mean :: Fractional a => [a] -> a+arithmetic_mean x = sum x / fromIntegral (length x)++-- | Numerically stable mean+--+-- > map ns_mean [[-3..3],[0..5],[1..5],[3,5,7],[7,7],[3,9,10,11,12]] == [0,2.5,3,5,7,9]+ns_mean :: Floating a => [a] -> a+ns_mean =+    let f (m,n) x = (m + (x - m) / (n + 1),n + 1)+    in fst . foldl' f (0,0)++-- | Square of /n/.+--+-- > square 5 == 25+square :: Num a => a -> a+square n = n * n++-- | The totient function phi(n), also called Euler's totient function.+--+-- > import Sound.SC3.Plot {- hsc3-plot -}+-- > plot_p1_stp [map totient [1::Int .. 100]]+totient :: Integral i => i -> i+totient n = genericLength (filter (==1) (map (gcd n) [1..n]))++{- | The /n/-th order Farey sequence.++> farey 1 == [0,                                                                                    1]+> farey 2 == [0,                                        1/2,                                        1]+> farey 3 == [0,                        1/3,            1/2,            2/3,                        1]+> farey 4 == [0,                1/4,    1/3,            1/2,            2/3,    3/4,                1]+> farey 5 == [0,            1/5,1/4,    1/3,    2/5,    1/2,    3/5,    2/3,    3/4,4/5,            1]+> farey 6 == [0,        1/6,1/5,1/4,    1/3,    2/5,    1/2,    3/5,    2/3,    3/4,4/5,5/6,        1]+> farey 7 == [0,    1/7,1/6,1/5,1/4,2/7,1/3,    2/5,3/7,1/2,4/7,3/5,    2/3,5/7,3/4,4/5,5/6,6/7,    1]+> farey 8 == [0,1/8,1/7,1/6,1/5,1/4,2/7,1/3,3/8,2/5,3/7,1/2,4/7,3/5,5/8,2/3,5/7,3/4,4/5,5/6,6/7,7/8,1]+-}+farey :: Integral i => i -> [Ratio i]+farey n =+  let step (a,b,c,d) =+        if c > n+        then Nothing+        else let k = (n + b) `quot` d in Just (c % d, (c,d,k * c - a,k * d - b))+  in 0 : unfoldr step (0,1,1,n)++-- | The length of the /n/-th order Farey sequence.+--+-- > map farey_length [1 .. 12] == [2,3,5,7,11,13,19,23,29,33,43,47]+-- > map (length . farey) [1 .. 12] == map farey_length [1 .. 12]+farey_length :: Integral i => i -> i+farey_length n = if n == 0 then 1 else farey_length (n - 1) + totient n++-- | Function to generate the Stern-Brocot tree from an initial row.+--   '%' normalises so 1/0 cannot be written as a 'Rational', hence (n,d).+stern_brocot_tree_f :: Num n => [(n,n)] -> [[(n,n)]]+stern_brocot_tree_f =+   let med_f (n1,d1) (n2,d2) = (n1 + n2,d1 + d2)+       f x = concat (transpose [x, zipWith med_f x (tail x)])+   in iterate f++{- | The Stern-Brocot tree from (0/1,1/0).++> let t = stern_brocot_tree+> t !! 0 == [(0,1),(1,0)]+> t !! 1 == [(0,1),(1,1),(1,0)]+> t !! 2 == [(0,1),(1,2),(1,1),(2,1),(1,0)]+> t !! 3 == [(0,1),(1,3),(1,2),(2,3),(1,1),(3,2),(2,1),(3,1),(1,0)]++> map length (take 12 stern_brocot_tree) == [2,3,5,9,17,33,65,129,257,513,1025,2049] -- A000051+-}+stern_brocot_tree :: Num n => [[(n,n)]]+stern_brocot_tree = stern_brocot_tree_f [(0,1),(1,0)]++-- | Left-hand (rational) side of the the Stern-Brocot tree, ie, from (0/1,1/1).+stern_brocot_tree_lhs :: Num n => [[(n,n)]]+stern_brocot_tree_lhs = stern_brocot_tree_f [(0,1),(1,1)]++{- | 'stern_brocot_tree_f' as 'Ratio's, for finite subsets.++> let t = stern_brocot_tree_f_r [0,1]+> t !! 1 == [0,1/2,1]+> t !! 2 == [0,1/3,1/2,2/3,1]+> t !! 3 == [0,1/4,1/3,2/5,1/2,3/5,2/3,3/4,1]+> t !! 4 == [0,1/5,1/4,2/7,1/3,3/8,2/5,3/7,1/2,4/7,3/5,5/8,2/3,5/7,3/4,4/5,1]+-}+stern_brocot_tree_f_r :: Integral n => [Ratio n] -> [[Ratio n]]+stern_brocot_tree_f_r = map (map (uncurry (%))) . stern_brocot_tree_f . map rational_nd
Music/Theory/Math/Convert.hs view
@@ -4,7 +4,7 @@ > map int_to_word8_maybe [-1,0,255,256] == [Nothing,Just 0,Just 255,Nothing]  > map integer_to_int64_maybe [-2 ^ 63 - 1,2 ^ 63] == [Nothing,Nothing]-> map integer_to_word64_maybe [2 ^64 - 1,2 ^ 64] == [Just 18446744073709551615,Nothing]+> map integer_to_word64_maybe [2 ^ 64 - 1,2 ^ 64] == [Just 18446744073709551615,Nothing]  > map int16_to_float [-1,0,1] == [-1,0,1] @@ -14,11 +14,15 @@ import Data.Int {- base -} import Data.Word {- base -} +-- * Numerical conversions+ -- | Type specialised 'realToFrac' real_to_float :: Real t => t -> Float real_to_float = realToFrac  -- | Type specialised 'realToFrac'+--+-- > let n = sqrt (-1) in (n,real_to_double n) real_to_double :: Real t => t -> Double real_to_double = realToFrac
+ Music/Theory/Math/Convert/FX.hs view
@@ -0,0 +1,1288 @@+-- | Conversion between SIGNED and SIZED integral types with bounds checking.+--   Types are aliased as Ux and Ix.+--   Includes sizes 4 (MIDI), 7 (ASCII,MIDI), 12 (SND,AKAI), 14 (MIDI) and 24 (SND).+--   AUTOGENERATED: SEE mk/mk-convert.hs.+module Music.Theory.Math.Convert.FX where++import Data.Int {- base -}+import Data.Word {- base -}++-- AUTOGEN++-- | Alias+type U4 = Word8++-- | Alias+type U7 = Word8++-- | Alias+type U8 = Word8++-- | Alias+type U12 = Word16++-- | Alias+type U14 = Word16++-- | Alias+type U16 = Word16++-- | Alias+type U24 = Word32++-- | Alias+type U32 = Word32++-- | Alias+type U64 = Word64++-- | Alias+type I4 = Int8++-- | Alias+type I7 = Int8++-- | Alias+type I8 = Int8++-- | Alias+type I12 = Int16++-- | Alias+type I14 = Int16++-- | Alias+type I16 = Int16++-- | Alias+type I24 = Int32++-- | Alias+type I32 = Int32++-- | Alias+type I64 = Int64++-- | Type specialised 'fromIntegral'+u4_to_u7 :: U4 -> U7+u4_to_u7 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u8 :: U4 -> U8+u4_to_u8 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u12 :: U4 -> U12+u4_to_u12 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u14 :: U4 -> U14+u4_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u16 :: U4 -> U16+u4_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u24 :: U4 -> U24+u4_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u32 :: U4 -> U32+u4_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u64 :: U4 -> U64+u4_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u4_to_i4 :: U4 -> I4+u4_to_i4 x = if x < 0 || x > 7 then error "u4_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u4_to_i7 :: U4 -> I7+u4_to_i7 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i8 :: U4 -> I8+u4_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i12 :: U4 -> I12+u4_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i14 :: U4 -> I14+u4_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i16 :: U4 -> I16+u4_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i24 :: U4 -> I24+u4_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i32 :: U4 -> I32+u4_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i64 :: U4 -> I64+u4_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u7_to_u4 :: U7 -> U4+u7_to_u4 x = if x < 0 || x > 15 then error "u7_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u7_to_u8 :: U7 -> U8+u7_to_u8 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u12 :: U7 -> U12+u7_to_u12 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u14 :: U7 -> U14+u7_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u16 :: U7 -> U16+u7_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u24 :: U7 -> U24+u7_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u32 :: U7 -> U32+u7_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u64 :: U7 -> U64+u7_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u7_to_i4 :: U7 -> I4+u7_to_i4 x = if x < 0 || x > 7 then error "u7_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u7_to_i7 :: U7 -> I7+u7_to_i7 x = if x < 0 || x > 63 then error "u7_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u7_to_i8 :: U7 -> I8+u7_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i12 :: U7 -> I12+u7_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i14 :: U7 -> I14+u7_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i16 :: U7 -> I16+u7_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i24 :: U7 -> I24+u7_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i32 :: U7 -> I32+u7_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i64 :: U7 -> I64+u7_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_u4 :: U8 -> U4+u8_to_u4 x = if x < 0 || x > 15 then error "u8_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_u7 :: U8 -> U7+u8_to_u7 x = if x < 0 || x > 127 then error "u8_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u8_to_u12 :: U8 -> U12+u8_to_u12 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u14 :: U8 -> U14+u8_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u16 :: U8 -> U16+u8_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u24 :: U8 -> U24+u8_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u32 :: U8 -> U32+u8_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u64 :: U8 -> U64+u8_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_i4 :: U8 -> I4+u8_to_i4 x = if x < 0 || x > 7 then error "u8_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_i7 :: U8 -> I7+u8_to_i7 x = if x < 0 || x > 63 then error "u8_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_i8 :: U8 -> I8+u8_to_i8 x = if x < 0 || x > 127 then error "u8_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u8_to_i12 :: U8 -> I12+u8_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i14 :: U8 -> I14+u8_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i16 :: U8 -> I16+u8_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i24 :: U8 -> I24+u8_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i32 :: U8 -> I32+u8_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i64 :: U8 -> I64+u8_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_u4 :: U12 -> U4+u12_to_u4 x = if x < 0 || x > 15 then error "u12_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_u7 :: U12 -> U7+u12_to_u7 x = if x < 0 || x > 127 then error "u12_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_u8 :: U12 -> U8+u12_to_u8 x = if x < 0 || x > 255 then error "u12_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u12_to_u14 :: U12 -> U14+u12_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u16 :: U12 -> U16+u12_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u24 :: U12 -> U24+u12_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u32 :: U12 -> U32+u12_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u64 :: U12 -> U64+u12_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i4 :: U12 -> I4+u12_to_i4 x = if x < 0 || x > 7 then error "u12_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i7 :: U12 -> I7+u12_to_i7 x = if x < 0 || x > 63 then error "u12_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i8 :: U12 -> I8+u12_to_i8 x = if x < 0 || x > 127 then error "u12_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i12 :: U12 -> I12+u12_to_i12 x = if x < 0 || x > 2047 then error "u12_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u12_to_i14 :: U12 -> I14+u12_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i16 :: U12 -> I16+u12_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i24 :: U12 -> I24+u12_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i32 :: U12 -> I32+u12_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i64 :: U12 -> I64+u12_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u4 :: U14 -> U4+u14_to_u4 x = if x < 0 || x > 15 then error "u14_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u7 :: U14 -> U7+u14_to_u7 x = if x < 0 || x > 127 then error "u14_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u8 :: U14 -> U8+u14_to_u8 x = if x < 0 || x > 255 then error "u14_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u12 :: U14 -> U12+u14_to_u12 x = if x < 0 || x > 4095 then error "u14_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u14_to_u16 :: U14 -> U16+u14_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_u24 :: U14 -> U24+u14_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_u32 :: U14 -> U32+u14_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_u64 :: U14 -> U64+u14_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i4 :: U14 -> I4+u14_to_i4 x = if x < 0 || x > 7 then error "u14_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i7 :: U14 -> I7+u14_to_i7 x = if x < 0 || x > 63 then error "u14_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i8 :: U14 -> I8+u14_to_i8 x = if x < 0 || x > 127 then error "u14_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i12 :: U14 -> I12+u14_to_i12 x = if x < 0 || x > 2047 then error "u14_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i14 :: U14 -> I14+u14_to_i14 x = if x < 0 || x > 8191 then error "u14_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u14_to_i16 :: U14 -> I16+u14_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_i24 :: U14 -> I24+u14_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_i32 :: U14 -> I32+u14_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_i64 :: U14 -> I64+u14_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u4 :: U16 -> U4+u16_to_u4 x = if x < 0 || x > 15 then error "u16_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u7 :: U16 -> U7+u16_to_u7 x = if x < 0 || x > 127 then error "u16_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u8 :: U16 -> U8+u16_to_u8 x = if x < 0 || x > 255 then error "u16_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u12 :: U16 -> U12+u16_to_u12 x = if x < 0 || x > 4095 then error "u16_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u14 :: U16 -> U14+u16_to_u14 x = if x < 0 || x > 16383 then error "u16_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u16_to_u24 :: U16 -> U24+u16_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_u32 :: U16 -> U32+u16_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_u64 :: U16 -> U64+u16_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i4 :: U16 -> I4+u16_to_i4 x = if x < 0 || x > 7 then error "u16_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i7 :: U16 -> I7+u16_to_i7 x = if x < 0 || x > 63 then error "u16_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i8 :: U16 -> I8+u16_to_i8 x = if x < 0 || x > 127 then error "u16_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i12 :: U16 -> I12+u16_to_i12 x = if x < 0 || x > 2047 then error "u16_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i14 :: U16 -> I14+u16_to_i14 x = if x < 0 || x > 8191 then error "u16_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i16 :: U16 -> I16+u16_to_i16 x = if x < 0 || x > 32767 then error "u16_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u16_to_i24 :: U16 -> I24+u16_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_i32 :: U16 -> I32+u16_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_i64 :: U16 -> I64+u16_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u4 :: U24 -> U4+u24_to_u4 x = if x < 0 || x > 15 then error "u24_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u7 :: U24 -> U7+u24_to_u7 x = if x < 0 || x > 127 then error "u24_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u8 :: U24 -> U8+u24_to_u8 x = if x < 0 || x > 255 then error "u24_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u12 :: U24 -> U12+u24_to_u12 x = if x < 0 || x > 4095 then error "u24_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u14 :: U24 -> U14+u24_to_u14 x = if x < 0 || x > 16383 then error "u24_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u16 :: U24 -> U16+u24_to_u16 x = if x < 0 || x > 65535 then error "u24_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u24_to_u32 :: U24 -> U32+u24_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u24_to_u64 :: U24 -> U64+u24_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i4 :: U24 -> I4+u24_to_i4 x = if x < 0 || x > 7 then error "u24_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i7 :: U24 -> I7+u24_to_i7 x = if x < 0 || x > 63 then error "u24_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i8 :: U24 -> I8+u24_to_i8 x = if x < 0 || x > 127 then error "u24_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i12 :: U24 -> I12+u24_to_i12 x = if x < 0 || x > 2047 then error "u24_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i14 :: U24 -> I14+u24_to_i14 x = if x < 0 || x > 8191 then error "u24_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i16 :: U24 -> I16+u24_to_i16 x = if x < 0 || x > 32767 then error "u24_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i24 :: U24 -> I24+u24_to_i24 x = if x < 0 || x > 8388607 then error "u24_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u24_to_i32 :: U24 -> I32+u24_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u24_to_i64 :: U24 -> I64+u24_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u4 :: U32 -> U4+u32_to_u4 x = if x < 0 || x > 15 then error "u32_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u7 :: U32 -> U7+u32_to_u7 x = if x < 0 || x > 127 then error "u32_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u8 :: U32 -> U8+u32_to_u8 x = if x < 0 || x > 255 then error "u32_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u12 :: U32 -> U12+u32_to_u12 x = if x < 0 || x > 4095 then error "u32_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u14 :: U32 -> U14+u32_to_u14 x = if x < 0 || x > 16383 then error "u32_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u16 :: U32 -> U16+u32_to_u16 x = if x < 0 || x > 65535 then error "u32_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u24 :: U32 -> U24+u32_to_u24 x = if x < 0 || x > 16777215 then error "u32_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u32_to_u64 :: U32 -> U64+u32_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i4 :: U32 -> I4+u32_to_i4 x = if x < 0 || x > 7 then error "u32_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i7 :: U32 -> I7+u32_to_i7 x = if x < 0 || x > 63 then error "u32_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i8 :: U32 -> I8+u32_to_i8 x = if x < 0 || x > 127 then error "u32_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i12 :: U32 -> I12+u32_to_i12 x = if x < 0 || x > 2047 then error "u32_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i14 :: U32 -> I14+u32_to_i14 x = if x < 0 || x > 8191 then error "u32_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i16 :: U32 -> I16+u32_to_i16 x = if x < 0 || x > 32767 then error "u32_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i24 :: U32 -> I24+u32_to_i24 x = if x < 0 || x > 8388607 then error "u32_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i32 :: U32 -> I32+u32_to_i32 x = if x < 0 || x > 2147483647 then error "u32_to_i32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u32_to_i64 :: U32 -> I64+u32_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u4 :: U64 -> U4+u64_to_u4 x = if x < 0 || x > 15 then error "u64_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u7 :: U64 -> U7+u64_to_u7 x = if x < 0 || x > 127 then error "u64_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u8 :: U64 -> U8+u64_to_u8 x = if x < 0 || x > 255 then error "u64_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u12 :: U64 -> U12+u64_to_u12 x = if x < 0 || x > 4095 then error "u64_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u14 :: U64 -> U14+u64_to_u14 x = if x < 0 || x > 16383 then error "u64_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u16 :: U64 -> U16+u64_to_u16 x = if x < 0 || x > 65535 then error "u64_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u24 :: U64 -> U24+u64_to_u24 x = if x < 0 || x > 16777215 then error "u64_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u32 :: U64 -> U32+u64_to_u32 x = if x < 0 || x > 4294967295 then error "u64_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i4 :: U64 -> I4+u64_to_i4 x = if x < 0 || x > 7 then error "u64_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i7 :: U64 -> I7+u64_to_i7 x = if x < 0 || x > 63 then error "u64_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i8 :: U64 -> I8+u64_to_i8 x = if x < 0 || x > 127 then error "u64_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i12 :: U64 -> I12+u64_to_i12 x = if x < 0 || x > 2047 then error "u64_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i14 :: U64 -> I14+u64_to_i14 x = if x < 0 || x > 8191 then error "u64_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i16 :: U64 -> I16+u64_to_i16 x = if x < 0 || x > 32767 then error "u64_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i24 :: U64 -> I24+u64_to_i24 x = if x < 0 || x > 8388607 then error "u64_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i32 :: U64 -> I32+u64_to_i32 x = if x < 0 || x > 2147483647 then error "u64_to_i32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i64 :: U64 -> I64+u64_to_i64 x = if x < 0 || x > 9223372036854775807 then error "u64_to_i64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u4 :: I4 -> U4+i4_to_u4 x = if x < 0 then error "i4_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u7 :: I4 -> U7+i4_to_u7 x = if x < 0 then error "i4_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u8 :: I4 -> U8+i4_to_u8 x = if x < 0 then error "i4_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u12 :: I4 -> U12+i4_to_u12 x = if x < 0 then error "i4_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u14 :: I4 -> U14+i4_to_u14 x = if x < 0 then error "i4_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u16 :: I4 -> U16+i4_to_u16 x = if x < 0 then error "i4_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u24 :: I4 -> U24+i4_to_u24 x = if x < 0 then error "i4_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u32 :: I4 -> U32+i4_to_u32 x = if x < 0 then error "i4_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u64 :: I4 -> U64+i4_to_u64 x = if x < 0 then error "i4_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i4_to_i7 :: I4 -> I7+i4_to_i7 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i8 :: I4 -> I8+i4_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i12 :: I4 -> I12+i4_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i14 :: I4 -> I14+i4_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i16 :: I4 -> I16+i4_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i24 :: I4 -> I24+i4_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i32 :: I4 -> I32+i4_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i64 :: I4 -> I64+i4_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u4 :: I7 -> U4+i7_to_u4 x = if x < 0 || x > 15 then error "i7_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u7 :: I7 -> U7+i7_to_u7 x = if x < 0 then error "i7_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u8 :: I7 -> U8+i7_to_u8 x = if x < 0 then error "i7_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u12 :: I7 -> U12+i7_to_u12 x = if x < 0 then error "i7_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u14 :: I7 -> U14+i7_to_u14 x = if x < 0 then error "i7_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u16 :: I7 -> U16+i7_to_u16 x = if x < 0 then error "i7_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u24 :: I7 -> U24+i7_to_u24 x = if x < 0 then error "i7_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u32 :: I7 -> U32+i7_to_u32 x = if x < 0 then error "i7_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u64 :: I7 -> U64+i7_to_u64 x = if x < 0 then error "i7_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_i4 :: I7 -> I4+i7_to_i4 x = if x < -8 || x > 7 then error "i7_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i7_to_i8 :: I7 -> I8+i7_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i12 :: I7 -> I12+i7_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i14 :: I7 -> I14+i7_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i16 :: I7 -> I16+i7_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i24 :: I7 -> I24+i7_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i32 :: I7 -> I32+i7_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i64 :: I7 -> I64+i7_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u4 :: I8 -> U4+i8_to_u4 x = if x < 0 || x > 15 then error "i8_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u7 :: I8 -> U7+i8_to_u7 x = if x < 0 || x > 127 then error "i8_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u8 :: I8 -> U8+i8_to_u8 x = if x < 0 then error "i8_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u12 :: I8 -> U12+i8_to_u12 x = if x < 0 then error "i8_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u14 :: I8 -> U14+i8_to_u14 x = if x < 0 then error "i8_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u16 :: I8 -> U16+i8_to_u16 x = if x < 0 then error "i8_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u24 :: I8 -> U24+i8_to_u24 x = if x < 0 then error "i8_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u32 :: I8 -> U32+i8_to_u32 x = if x < 0 then error "i8_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u64 :: I8 -> U64+i8_to_u64 x = if x < 0 then error "i8_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_i4 :: I8 -> I4+i8_to_i4 x = if x < -8 || x > 7 then error "i8_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_i7 :: I8 -> I7+i8_to_i7 x = if x < -64 || x > 63 then error "i8_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i8_to_i12 :: I8 -> I12+i8_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i14 :: I8 -> I14+i8_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i16 :: I8 -> I16+i8_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i24 :: I8 -> I24+i8_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i32 :: I8 -> I32+i8_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i64 :: I8 -> I64+i8_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u4 :: I12 -> U4+i12_to_u4 x = if x < 0 || x > 15 then error "i12_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u7 :: I12 -> U7+i12_to_u7 x = if x < 0 || x > 127 then error "i12_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u8 :: I12 -> U8+i12_to_u8 x = if x < 0 || x > 255 then error "i12_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u12 :: I12 -> U12+i12_to_u12 x = if x < 0 then error "i12_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u14 :: I12 -> U14+i12_to_u14 x = if x < 0 then error "i12_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u16 :: I12 -> U16+i12_to_u16 x = if x < 0 then error "i12_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u24 :: I12 -> U24+i12_to_u24 x = if x < 0 then error "i12_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u32 :: I12 -> U32+i12_to_u32 x = if x < 0 then error "i12_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u64 :: I12 -> U64+i12_to_u64 x = if x < 0 then error "i12_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_i4 :: I12 -> I4+i12_to_i4 x = if x < -8 || x > 7 then error "i12_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_i7 :: I12 -> I7+i12_to_i7 x = if x < -64 || x > 63 then error "i12_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_i8 :: I12 -> I8+i12_to_i8 x = if x < -128 || x > 127 then error "i12_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i12_to_i14 :: I12 -> I14+i12_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i16 :: I12 -> I16+i12_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i24 :: I12 -> I24+i12_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i32 :: I12 -> I32+i12_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i64 :: I12 -> I64+i12_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u4 :: I14 -> U4+i14_to_u4 x = if x < 0 || x > 15 then error "i14_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u7 :: I14 -> U7+i14_to_u7 x = if x < 0 || x > 127 then error "i14_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u8 :: I14 -> U8+i14_to_u8 x = if x < 0 || x > 255 then error "i14_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u12 :: I14 -> U12+i14_to_u12 x = if x < 0 || x > 4095 then error "i14_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u14 :: I14 -> U14+i14_to_u14 x = if x < 0 then error "i14_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u16 :: I14 -> U16+i14_to_u16 x = if x < 0 then error "i14_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u24 :: I14 -> U24+i14_to_u24 x = if x < 0 then error "i14_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u32 :: I14 -> U32+i14_to_u32 x = if x < 0 then error "i14_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u64 :: I14 -> U64+i14_to_u64 x = if x < 0 then error "i14_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i4 :: I14 -> I4+i14_to_i4 x = if x < -8 || x > 7 then error "i14_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i7 :: I14 -> I7+i14_to_i7 x = if x < -64 || x > 63 then error "i14_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i8 :: I14 -> I8+i14_to_i8 x = if x < -128 || x > 127 then error "i14_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i12 :: I14 -> I12+i14_to_i12 x = if x < -2048 || x > 2047 then error "i14_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i14_to_i16 :: I14 -> I16+i14_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i14_to_i24 :: I14 -> I24+i14_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i14_to_i32 :: I14 -> I32+i14_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i14_to_i64 :: I14 -> I64+i14_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u4 :: I16 -> U4+i16_to_u4 x = if x < 0 || x > 15 then error "i16_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u7 :: I16 -> U7+i16_to_u7 x = if x < 0 || x > 127 then error "i16_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u8 :: I16 -> U8+i16_to_u8 x = if x < 0 || x > 255 then error "i16_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u12 :: I16 -> U12+i16_to_u12 x = if x < 0 || x > 4095 then error "i16_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u14 :: I16 -> U14+i16_to_u14 x = if x < 0 || x > 16383 then error "i16_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u16 :: I16 -> U16+i16_to_u16 x = if x < 0 then error "i16_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u24 :: I16 -> U24+i16_to_u24 x = if x < 0 then error "i16_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u32 :: I16 -> U32+i16_to_u32 x = if x < 0 then error "i16_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u64 :: I16 -> U64+i16_to_u64 x = if x < 0 then error "i16_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i4 :: I16 -> I4+i16_to_i4 x = if x < -8 || x > 7 then error "i16_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i7 :: I16 -> I7+i16_to_i7 x = if x < -64 || x > 63 then error "i16_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i8 :: I16 -> I8+i16_to_i8 x = if x < -128 || x > 127 then error "i16_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i12 :: I16 -> I12+i16_to_i12 x = if x < -2048 || x > 2047 then error "i16_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i14 :: I16 -> I14+i16_to_i14 x = if x < -8192 || x > 8191 then error "i16_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i16_to_i24 :: I16 -> I24+i16_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i16_to_i32 :: I16 -> I32+i16_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i16_to_i64 :: I16 -> I64+i16_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u4 :: I24 -> U4+i24_to_u4 x = if x < 0 || x > 15 then error "i24_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u7 :: I24 -> U7+i24_to_u7 x = if x < 0 || x > 127 then error "i24_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u8 :: I24 -> U8+i24_to_u8 x = if x < 0 || x > 255 then error "i24_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u12 :: I24 -> U12+i24_to_u12 x = if x < 0 || x > 4095 then error "i24_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u14 :: I24 -> U14+i24_to_u14 x = if x < 0 || x > 16383 then error "i24_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u16 :: I24 -> U16+i24_to_u16 x = if x < 0 || x > 65535 then error "i24_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u24 :: I24 -> U24+i24_to_u24 x = if x < 0 then error "i24_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u32 :: I24 -> U32+i24_to_u32 x = if x < 0 then error "i24_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u64 :: I24 -> U64+i24_to_u64 x = if x < 0 then error "i24_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i4 :: I24 -> I4+i24_to_i4 x = if x < -8 || x > 7 then error "i24_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i7 :: I24 -> I7+i24_to_i7 x = if x < -64 || x > 63 then error "i24_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i8 :: I24 -> I8+i24_to_i8 x = if x < -128 || x > 127 then error "i24_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i12 :: I24 -> I12+i24_to_i12 x = if x < -2048 || x > 2047 then error "i24_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i14 :: I24 -> I14+i24_to_i14 x = if x < -8192 || x > 8191 then error "i24_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i16 :: I24 -> I16+i24_to_i16 x = if x < -32768 || x > 32767 then error "i24_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i24_to_i32 :: I24 -> I32+i24_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i24_to_i64 :: I24 -> I64+i24_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u4 :: I32 -> U4+i32_to_u4 x = if x < 0 || x > 15 then error "i32_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u7 :: I32 -> U7+i32_to_u7 x = if x < 0 || x > 127 then error "i32_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u8 :: I32 -> U8+i32_to_u8 x = if x < 0 || x > 255 then error "i32_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u12 :: I32 -> U12+i32_to_u12 x = if x < 0 || x > 4095 then error "i32_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u14 :: I32 -> U14+i32_to_u14 x = if x < 0 || x > 16383 then error "i32_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u16 :: I32 -> U16+i32_to_u16 x = if x < 0 || x > 65535 then error "i32_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u24 :: I32 -> U24+i32_to_u24 x = if x < 0 || x > 16777215 then error "i32_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u32 :: I32 -> U32+i32_to_u32 x = if x < 0 then error "i32_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u64 :: I32 -> U64+i32_to_u64 x = if x < 0 then error "i32_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i4 :: I32 -> I4+i32_to_i4 x = if x < -8 || x > 7 then error "i32_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i7 :: I32 -> I7+i32_to_i7 x = if x < -64 || x > 63 then error "i32_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i8 :: I32 -> I8+i32_to_i8 x = if x < -128 || x > 127 then error "i32_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i12 :: I32 -> I12+i32_to_i12 x = if x < -2048 || x > 2047 then error "i32_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i14 :: I32 -> I14+i32_to_i14 x = if x < -8192 || x > 8191 then error "i32_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i16 :: I32 -> I16+i32_to_i16 x = if x < -32768 || x > 32767 then error "i32_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i24 :: I32 -> I24+i32_to_i24 x = if x < -8388608 || x > 8388607 then error "i32_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i32_to_i64 :: I32 -> I64+i32_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u4 :: I64 -> U4+i64_to_u4 x = if x < 0 || x > 15 then error "i64_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u7 :: I64 -> U7+i64_to_u7 x = if x < 0 || x > 127 then error "i64_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u8 :: I64 -> U8+i64_to_u8 x = if x < 0 || x > 255 then error "i64_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u12 :: I64 -> U12+i64_to_u12 x = if x < 0 || x > 4095 then error "i64_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u14 :: I64 -> U14+i64_to_u14 x = if x < 0 || x > 16383 then error "i64_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u16 :: I64 -> U16+i64_to_u16 x = if x < 0 || x > 65535 then error "i64_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u24 :: I64 -> U24+i64_to_u24 x = if x < 0 || x > 16777215 then error "i64_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u32 :: I64 -> U32+i64_to_u32 x = if x < 0 || x > 4294967295 then error "i64_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u64 :: I64 -> U64+i64_to_u64 x = if x < 0 then error "i64_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i4 :: I64 -> I4+i64_to_i4 x = if x < -8 || x > 7 then error "i64_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i7 :: I64 -> I7+i64_to_i7 x = if x < -64 || x > 63 then error "i64_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i8 :: I64 -> I8+i64_to_i8 x = if x < -128 || x > 127 then error "i64_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i12 :: I64 -> I12+i64_to_i12 x = if x < -2048 || x > 2047 then error "i64_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i14 :: I64 -> I14+i64_to_i14 x = if x < -8192 || x > 8191 then error "i64_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i16 :: I64 -> I16+i64_to_i16 x = if x < -32768 || x > 32767 then error "i64_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i24 :: I64 -> I24+i64_to_i24 x = if x < -8388608 || x > 8388607 then error "i64_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i32 :: I64 -> I32+i64_to_i32 x = if x < -2147483648 || x > 2147483647 then error "i64_to_i32: OUT-OF-RANGE" else fromIntegral x
+ Music/Theory/Math/Nichomachus.hs view
@@ -0,0 +1,53 @@+{- | Nichomachus of Gerasa (Νικόμαχος) c.60-c.120++<https://pdfs.semanticscholar.org/5dac/8842ad857c822ab854ede3decadfe0464f15.pdf>+-}+module Music.Theory.Math.Nichomachus where++{- | a-b = b-c ; b = a+c / 2++> arithmetic_mean 2 6 == 4+> arithmetic_mean 1 2 == (1+2)/2 -- 3/2+-}+arithmetic_mean :: Fractional a => a -> a -> a+arithmetic_mean a c = (a + c) / 2++{- | a/b = b/c ; b = sqrt ac++> geometric_mean 1 4 == 2+> geometric_mean 1 2 == sqrt (1*2) -- sqrt 2+-}+geometric_mean :: Floating a => a -> a -> a+geometric_mean a c = sqrt (a * c)++{- | a-b / a = b-c / c ; 2ac / a+c++> harmonic_mean 2 6 == 3+> harmonic_mean 1 2 == (2*1*2)/(1+2) -- 4/3+-}+harmonic_mean :: Fractional a => a -> a -> a+harmonic_mean a c = (2 * a * c) / (a + c) -- OR -- 2 / (1/a + 1/c)++{- | a-b / c = b-c / a ; a-b / b-c = c/a ; aa+cc / a+c++> cont_harmonic_mean 3 6 == 5+> cont_harmonic_mean 1 2 == (1*1+2*2)/(1+2) -- 5/3+-}+cont_harmonic_mean :: Fractional a => a -> a -> a+cont_harmonic_mean a c = (a * a + c * c) / (a + c)++{- | a-b / c = b-c / b ; a-b / b-c = c/b ; c - a + (sqrt (5aa - 2ac + cc)) / 2++> cont_geometric_mean 2 5 == 4+> cont_geometric_mean 1 2 == (2-1+sqrt(5*1*1-2*1*2+2*2))/2 -- (1+sqrt 5)/2 -- GOLDEN RATIO -- 1.6180+-}+cont_geometric_mean :: Floating a => a -> a -> a+cont_geometric_mean a c = (c - a + (sqrt (5 * a * a - 2 * a * c + c * c))) / 2++{- | a-b / c = b-c / b ; a-b / b-c = c/b ; a - c + (sqrt (aa - 2ac + 5cc)) / 2++> subcont_geometric_mean 1 6 == 4+> subcont_geometric_mean 1 2 == (-1 + sqrt 17) / 2 -- 1.5616+-}+subcont_geometric_mean :: Floating a => a -> a -> a+subcont_geometric_mean a c = (a - c + (sqrt (a * a - 2 * a * c + 5 * c * c))) / 2
Music/Theory/Math/OEIS.hs view
@@ -1,27 +1,470 @@ -- | The On-Line Encyclopedia of Integer Sequences, <http://oeis.org/> module Music.Theory.Math.OEIS where --- | <http://oeis.org/A000290>------ The squares of the non-negative integers.------ > import Data.List--- > [0,1,4,9,16,25,36,49,64,81,100] `isInfixOf` a000290+import Data.List {- base -}+import Data.Ratio {- base -}++import qualified Music.Theory.Math as Math {- hmt -}++{- | <http://oeis.org/A000010>++Euler totient function phi(n): count numbers <= n and prime to n.++> [1,1,2,2,4,2,6,4,6,4,10,4,12,6,8,8,16,6,18,8,12,10,22,8,20,12] `isPrefixOf` a000010+-}+a000010 :: Integral n => [n]+a000010 =+  let phi n = genericLength (filter (==1) (map (gcd n) [1..n]))+  in map phi [1::Integer ..]++{- | <http://oeis.org/A000045>++Fibonacci numbers++> [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610] `isPrefixOf` a000045+-}+a000045 :: Num n => [n]+a000045 = 0 : 1 : zipWith (+) a000045 (tail a000045)++{- | <http://oeis.org/A000051>++a(n) = 2^n + 1++> [2,3,5,9,17,33,65,129,257,513,1025,2049,4097,8193,16385,32769,65537,131073] `isPrefixOf` a000051+-}+a000051 :: Num n => [n]+a000051 = iterate ((subtract 1) . (* 2)) 2++{- | <http://oeis.org/A000079>++Powers of 2: a(n) = 2^n++> [1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768,65536] `isPrefixOf` a000079+-}+a000079 :: Num n => [n]+a000079 = iterate (* 2) 1++{- | <http://oeis.org/A000142>++Factorial numbers: n! = 1*2*3*4*...*n+(order of symmetric group S_n, number of permutations of n letters).++> [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800,479001600,6227020800] `isPrefixOf` a000142+-}+a000142 :: (Enum n, Num n) => [n]+a000142 = 1 : zipWith (*) [1..] a000142++{- | https://oeis.org/A000201++Lower Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi), where phi = (1+sqrt(5))/2 = A001622++> [1,3,4,6,8,9,11,12,14,16,17,19,21,22,24,25,27,29,30,32,33,35,37,38,40,42] `isPrefixOf` a000201++> import Sound.SC3.Plot {- hsc3-plot -}+> plot_p1_imp [take 128 a000201 :: [Int]]+-}+a000201 :: Integral n => [n]+a000201 =+  let f (x:xs) (y:ys) = y : f xs (delete (x + y) ys)+      f _ _ = error "a000201"+  in f [1..] [1..]++{- | <https://oeis.org/A000204>++Lucas numbers (beginning with 1): L(n) = L(n-1) + L(n-2) with L(1) = 1, L(2) = 3++> [1,3,4,7,11,18,29,47,76,123,199,322,521,843,1364,2207,3571,5778,9349,15127] `isPrefixOf` a000204+-}+a000204 :: Num n => [n]+a000204 = 1 : 3 : zipWith (+) a000204 (tail a000204)++{- | <https://oeis.org/A000217>++Triangular numbers: a(n) = binomial(n+1,2) = n(n+1)/2 = 0 + 1 + 2 + ... + n.++> [0,1,3,6,10,15,21,28,36,45,55,66,78,91,105,120,136,153,171,190,210,231,253,276] `isPrefixOf` a000217+-}+a000217 :: (Enum n,Num n) => [n]+a000217 = scanl1 (+) [0..]++{- | <http://oeis.org/A000225>++a(n) = 2^n - 1 (Sometimes called Mersenne numbers, although that name is usually reserved for A001348)++> [0,1,3,7,15,31,63,127,255,511,1023,2047,4095,8191,16383,32767,65535] `isPrefixOf` a000225+-}+a000225 :: Num n => [n]+a000225 = iterate ((+ 1) . (* 2)) 0++{- | <http://oeis.org/A000290>++The squares of the non-negative integers.++> [0,1,4,9,16,25,36,49,64,81,100] `isPrefixOf` a000290+-} a000290 :: Integral n => [n] a000290 = let square n = n * n in map square [0..] +{- | <https://oeis.org/A000292>++Tetrahedral (or triangular pyramidal) numbers: a(n) = C(n+2,3) = n*(n+1)*(n+2)/6.++> [0,1,4,10,20,35,56,84,120,165,220,286,364,455,560,680,816,969,1140,1330,1540] `isPrefixOf` a000292+-}+a000292 :: (Enum n,Num n) => [n]+a000292 = scanl1 (+) a000217++{- | <https://oeis.org/A000930>++Narayana's cows sequence.++> [1,1,1,2,3,4,6,9,13,19,28,41,60] `isPrefixOf` a000930+-}+a000930 :: Num n => [n]+a000930 = 1 : 1 : 1 : zipWith (+) a000930 (drop 2 a000930)++{- | <https://oeis.org/A000931>++Padovan sequence (or Padovan numbers)++> [1,0,0,1,0,1,1,1,2,2,3,4,5,7,9,12,16,21,28,37,49,65,86,114,151,200,265] `isPrefixOf` a000931+-}+a000931 :: Num n => [n]+a000931 = 1 : 0 : 0 : zipWith (+) a000931 (tail a000931)++{- | <https://oeis.org/A001008>++Numerators of harmonic numbers H(n) = Sum_{i=1..n} 1/i++[1,3,11,25,137,49,363,761,7129,7381,83711,86021,1145993,1171733,1195757,2436559] `isPrefixOf` a001008+-}+a001008 :: Integral i => [i]+a001008 = map numerator (scanl1 (+) (map (1 %) [1..]))++{- | <https://oeis.org/A001333>++Numerators of continued fraction convergents to sqrt(2).++[1,1,3,7,17,41,99,239,577,1393,3363,8119,19601,47321,114243,275807,665857] `isPrefixOf` a001333+-}+a001333 :: Num n => [n]+a001333 = 1 : 1 : zipWith (+) a001333 (map (* 2) (tail a001333))++{- | <http://oeis.org/A001687>++a(n) = a(n-2) + a(n-5).++[0,1,0,1,0,1,1,1,2,1,3,2,4,4,5,7,7,11,11,16,18,23,29,34,45,52,68,81,102,126,154] `isPrefixOf` a001687+-}+a001687 :: Num n => [n]+a001687 = 0 : 1 : 0 : 1 : 0 : zipWith (+) a001687 (drop 3 a001687)++{- | <https://oeis.org/A001950>++Upper Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi^2), where phi = (1+sqrt(5))/2++> [2,5,7,10,13,15,18,20,23,26,28,31,34,36,39,41,44,47,49,52,54,57,60,62,65] `isPrefixOf` a001950+-}+a001950 :: Integral n => [n]+a001950 = zipWith (+) a000201 [1..]+ -- | <http://oeis.org/A002267>+--+-- The 15 supersingular primes. a002267 :: Num n => [n] a002267 = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 41, 47, 59, 71] +{- | <https://oeis.org/A002487>++Stern's diatomic series (or Stern-Brocot sequence)++> [0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5] `isPrefixOf` a002487+-}+a002487 :: Num n => [n]+a002487 =+  let f (a:a') (b:b') = a + b : a : f a' b'+      f _ _ = error "a002487?"+      x = 1 : 1 : f (tail x) x+  in 0 : x++-- | <http://oeis.org/A003269>+--+-- [0,1,1,1,1,2,3,4,5,7,10,14,19,26,36,50,69,95,131,181,250,345,476,657] `isPrefixOf` a003269+a003269 :: Num n => [n]+a003269 = 0 : 1 : 1 : 1 : zipWith (+) a003269 (drop 3 a003269)++{- | <http://oeis.org/A003520>++a(n) = a(n-1) + a(n-5); a(0) = ... = a(4) = 1.++> [1,1,1,1,1,2,3,4,5,6,8,11,15,20,26,34,45,60,80,106,140,185,245,325,431] `isPrefixOf` a003520+-}+a003520 :: Num n => [n]+a003520 = 1 : 1 : 1 : 1 : 1 : zipWith (+) a003520 (drop 4 a003520)++{- | <https://oeis.org/A003849>++The infinite Fibonacci word (start with 0, apply 0->01, 1->0, take limit).++> [0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0] `isPrefixOf` a003849+-}+a003849 :: Num n => [n]+a003849 =+  let fws = [1] : [0] : zipWith (++) fws (tail fws)+  in tail (concat fws)++{- | <http://oeis.org/A004718>++Per Nørgård's "infinity sequence"++> take 32 a004718 == [0,1,-1,2,1,0,-2,3,-1,2,0,1,2,-1,-3,4,1,0,-2,3,0,1,-1,2,-2,3,1,0,3,-2,-4,5]++> plot_p1_imp [take 1024 a004718]++<https://www.tandfonline.com/doi/abs/10.1080/17459737.2017.1299807>+<https://arxiv.org/pdf/1402.3091.pdf>++-}+a004718 :: Num n => [n]+a004718 = 0 : concat (transpose [map (+ 1) a004718, map negate (tail a004718)])++{- | <http://oeis.org/A005728>++Number of fractions in Farey series of order n.++> [1,2,3,5,7,11,13,19,23,29,33,43,47,59,65,73,81,97,103,121,129,141,151] `isPrefixOf` a005728+-}+a005728 :: Integral i => [i]+a005728 =+  let phi n = genericLength (filter (==1) (map (gcd n) [1..n]))+      f n = if n == 0 then 1 else f (n - 1) + phi n+  in map f [0::Integer ..]++{- | <http://oeis.org/A005811>++Number of runs in binary expansion of n (n>0); number of 1's in Gray code for n++> take 32 a005811 == [0,1,2,1,2,3,2,1,2,3,4,3,2,3,2,1,2,3,4,3,4,5,4,3,2,3,4,3,2,3,2,1]+-}+a005811 :: Integral n => [n]+a005811 =+  let f (x:xs) = x : f (xs ++ [x + x `mod` 2, x + 1 - x `mod` 2])+      f _ = error "A005811?"+  in 0 : f [1]++{- | <http://oeis.org/A006842>++Triangle read by rows: row n gives numerators of Farey series of order n.++> [0,1,0,1,1,0,1,1,2,1,0,1,1,1,2,3,1,0,1,1,1,2,1,3,2,3,4,1,0,1,1,1,1,2,1,3] `isPrefixOf` a006842+> plot_p1_imp [take 200 (a006842 :: [Int])]+> plot_p1_pt [take 10000 (a006842 :: [Int])]+-}+a006842 :: Integral i => [i]+a006842 = map numerator (concatMap Math.farey [1..])++{- | <http://oeis.org/A006843>++Triangle read by rows: row n gives denominators of Farey series of order n++> [1,1,1,2,1,1,3,2,3,1,1,4,3,2,3,4,1,1,5,4,3,5,2,5,3,4,5,1,1,6,5,4,3,5,2,5] `isPrefixOf` a006843+> plot_p1_imp [take 200 (a006843 :: [Int])]+> plot_p1_pt [take 10000 (a006843 :: [Int])]+-}+a006843 :: Integral i => [i]+a006843 = map denominator (concatMap Math.farey [1..])++{- | <https://oeis.org/A007318>++Pascal's triangle read by rows++[[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1],[1,5,10,10,5,1]] `isPrefixOf` a007318+-}+a007318 :: Integral i => [[i]]+a007318 =+  let f r = zipWith (+) ([0] ++ r) (r ++ [0])+  in iterate f [1]++{- | <https://oeis.org/A008277>++Triangle of Stirling numbers of the second kind, S2(n,k), n >= 1, 1 <= k <= n.++[1,1,1,1,3,1,1,7,6,1,1,15,25,10,1,1,31,90,65,15,1,1,63,301,350,140,21,1] `isPrefixOf` a008277+-}+a008277 :: (Enum n,Num n) => [n]+a008277 = concat a008277_tbl++a008277_tbl :: (Enum n,Num n) => [[n]]+a008277_tbl = map tail $ a048993_tbl++{- | <http://oeis.org/A008278>++Triangle of Stirling numbers of 2nd kind, S(n,n-k+1), n >= 1, 1<=k<=n.++[1,1,1,1,3,1,1,6,7,1,1,10,25,15,1,1,15,65,90,31,1,1,21,140,350,301,63,1] `isPrefixOf` a008278+-}+a008278 :: (Enum n,Num n) => [n]+a008278 = concat a008278_tbl++a008278_tbl :: (Enum n,Num n) => [[n]]+a008278_tbl =+  let f p =+        let q = reverse (zipWith (*) [1..] (reverse p))+        in zipWith (+) ([0] ++ q) (p ++ [0])+  in iterate f [1]++{- | <http://oeis.org/A017817>++a(n) = a(n-3) + a(n-4), with a(0)=1, a(1)=a(2)=0, a(3)=1++> [1,0,0,1,1,0,1,2,1,1,3,3,2,4,6,5,6,10,11,11,16,21,22,27,37,43,49,64,80,92] `isPrefixOf` a017817+-}+a017817 :: Num n => [n]+a017817 = 1 : 0 : 0 : 1 : zipWith (+) a017817 (tail a017817)+++{- | <http://oeis.org/A030308>++Triangle T(n,k): Write n in base 2, reverse order of digits, to get the n-th row++> take 9 a030308 == [[0],[1],[0,1],[1,1],[0,0,1],[1,0,1],[0,1,1],[1,1,1],[0,0,0,1]]+-}+a030308 :: (Eq n,Num n) => [[n]]+a030308 =+   let f l = case l of+         [] -> [1]+         0:b -> 1 : b+         1:b -> 0 : f b+         _ -> error "A030308?"+   in iterate f [0]++{- | <https://oeis.org/A048993>++Triangle of Stirling numbers of 2nd kind, S(n,k), n >= 0, 0 <= k <= n.++> [1,0,1,0,1,1,0,1,3,1,0,1,7,6,1,0,1,15,25,10,1,0,1,31,90,65,15,1] `isPrefixOf` a048993+-}+a048993 :: (Enum n,Num n) => [n]+a048993 = concat a048993_tbl++a048993_tbl :: (Enum n,Num n) => [[n]]+a048993_tbl = iterate (\row -> [0] ++ (zipWith (+) row $ zipWith (*) [1..] $ tail row) ++ [1]) [1]++{- | <http://oeis.org/A049455>++Triangle read by rows, numerator of fractions of a variant of the Farey series.++> [0,1,0,1,1,0,1,1,2,1,0,1,1,2,1,3,2,3,1,0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,0] `isPrefixOf` a049455+> plot_p1_imp [take 200 (a049455 :: [Int])]+> plot_p1_pt [take 10000 (a049455 :: [Int])]+-}+a049455 :: Integral n => [n]+a049455 = map fst (concat Math.stern_brocot_tree_lhs)++{- | <http://oeis.org/A049456>++Triangle read by rows, denominator of fractions of a variant of the Farey series.++[1,1,1,2,1,1,3,2,3,1,1,4,3,5,2,5,3,4,1,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5,1,1,6,5,9] `isPrefixOf` a049456+> plot_p1_imp [take 200 (a049456 :: [Int])]+> plot_p1_pt [take 10000 (a049456 :: [Int])]+-}+a049456 :: Integral n => [n]+a049456 = map snd (concat Math.stern_brocot_tree_lhs)++{- | <http://oeis.org/A073334>++The "rhythmic infinity system" of Danish composer Per Nørgård++> take 24 a073334 == [3,5,8,5,8,13,8,5,8,13,21,13,8,13,8,5,8,13,21,13,21,34,21,13]+> plot_p1_imp [take 200 (a073334 :: [Int])]+-}+a073334 :: Num n => [n]+a073334 =+  let f n = a000045 !! ((a005811 !! n) + 4)+  in 3 : map f [1..]++-- | <http://oeis.org/A080992>+--+-- Entries in Durer's magic square.+a080992 :: Num n => [n]+a080992 =+  [16,03,02,13+  ,05,10,11,08+  ,09,06,07,12+  ,04,15,14,01]++{- | <http://oeis.org/A083866>++Positions of zeros in Per Nørgård's infinity sequence (A004718).++> take 24 a083866 == [0,5,10,17,20,27,34,40,45,54,65,68,75,80,85,90,99,105,108,119,130,136,141,150]+-}+a083866 :: (Enum n,Num n) => [n]+a083866 = map snd (filter ((== (0::Int)) . fst) (zip a004718 [0..]))+ -- | <http://oeis.org/A126709> -- -- Loh-Shu magic square, attributed to the legendary Fu Xi (Fuh-Hi). a126709 :: Num n => [n]-a126709 = [4, 9, 2, 3, 5, 7, 8, 1, 6]+a126709 =+  [4,9,2+  ,3,5,7+  ,8,1,6]  -- | <http://oeis.org/A126710> -- -- Jaina inscription of the twelfth or thirteenth century, Khajuraho, India. a126710 :: Num n => [n]-a126710 = [7, 12, 1, 14, 2, 13, 8, 11, 16, 3, 10, 5, 9, 6, 15, 4]+a126710 =+  [07,12,01,14+  ,02,13,08,11+  ,16,03,10,05+  ,09,06,15,04]++-- | <http://oeis.org/A126976>+--+-- Agrippa (Magic Square of the Sun)+a126976 :: Num n => [n]+a126976 =+  [06,32,03,34,35,01+  ,07,11,27,28,08,30+  ,19,14,16,15,23,24+  ,18,20,22,21,17,13+  ,25,29,10,09,26,12+  ,36,05,33,04,02,31]++{- | <http://oeis.org/A255723>++Another variant of Per Nørgård's "infinity sequence"++> take 24 a255723 == [0,-2,-1,2,-2,-4,1,0,-1,-3,0,1,2,0,-3,4,-2,-4,1,0,-4,-6,3,-2]+> plot_p1_imp [take 400 (a255723 :: [Int])]+-}+a255723 :: Num n => [n]+a255723 = 0 : concat (transpose [map (subtract 2) a255723+                                ,map (-1 -) a255723+                                ,map (+ 2) a255723+                                ,tail a255723])++{- | <http://oeis.org/A256184>++First of two variations by Per Nørgård of his "infinity sequence"++> take 24 a256184 == [0,-2,-1,2,-4,-3,1,-3,-2,-2,0,1,4,-6,-5,3,-5,-4,-1,-1,0,3,-5,-4]+-}+a256184 :: Num n => [n]+a256184 = 0 : concat (transpose [map (subtract 2) a256184+                                ,map (subtract 1) a256184+                                ,map negate (tail a256184)])++{- | <http://oeis.org/A256185>++Second of two variations by Per Nørgård of his "infinity sequence"++> take 24 a256185 == [0,-3,-2,3,-6,1,2,-5,0,-3,0,-5,6,-9,4,-1,-2,-3,-2,-1,-4,5,-8,3]+-}+a256185 :: Num n => [n]+a256185 = 0 : concat (transpose [map (subtract 3) a256185+                                ,map (-2 -) a256185+                                ,map negate (tail a256185)])
+ Music/Theory/Math/Prime.hs view
@@ -0,0 +1,189 @@+-- | Prime number related functions.+module Music.Theory.Math.Prime where++import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -}++import qualified Data.Numbers.Primes as P {- primes -}++import qualified Music.Theory.Function as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Math as T {- hmt -}++-- | Alias for 'P.primes'.+--+-- > take 12 primes_list == [2,3,5,7,11,13,17,19,23,29,31,37]+primes_list :: Integral i => [i]+primes_list = P.primes++-- | Give zero-index of prime.+--+-- > map prime_k [2,3,5,7,11,13,17,19,23,29,31,37] == map Just [0 .. 11]+-- > map prime_k [1,4,6,8,9,10,12,14,15,16,18,20,21,22] == replicate 14 Nothing+prime_k :: Integral a => a -> Maybe Int+prime_k i = if P.isPrime i then Just (T.findIndex_err (== i) P.primes) else Nothing++-- > prime_k_err 13 == 5+prime_k_err :: Integral a => a -> Int+prime_k_err = fromMaybe (error "prime_k: not prime?") . prime_k++{- | Generate list of factors of /n/ from /x/.++> factor primes_list 315 == [3,3,5,7]+> P.primeFactors 315 == [3,3,5,7]++As a special case 1 gives the empty list.++> factor primes_list 1 == []+> P.primeFactors 1 == []+-}+factor :: Integral i => [i] -> i -> [i]+factor x n =+    case x of+      [] -> undefined+      i:x' -> if n < i+              then [] -- ie. prime factors of 1...+              else if i * i > n+                   then [n]+                   else if rem n i == 0+                        then i : factor x (quot n i)+                        else factor x' n++-- | 'factor' of 'primes_list'.+--+-- > map prime_factors [-1,0,1] == [[],[],[]]+-- > map prime_factors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]]+-- > map P.primeFactors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]]+prime_factors :: Integral i => i -> [i]+prime_factors n = factor primes_list n++-- | 'maximum' of 'prime_factors'+--+-- > map prime_limit [243,125] == [3,5]+-- > map prime_limit [0,1] == [1,1]+prime_limit :: Integral i => i -> i+prime_limit x = if x < 2 then 1 else maximum (prime_factors x)++-- | Collect number of occurences of each element of a sorted list.+--+-- > multiplicities [1,1,1,2,2,3] == [(1,3),(2,2),(3,1)]+multiplicities :: Eq t => [t] -> [(t,Int)]+multiplicities = T.generic_histogram_by (==) Nothing++-- | Pretty printer for histogram (multiplicites).+--+-- > multiplicities_pp [(3,2),(5,1),(7,1)] == "3×2 5×1 7×1"+multiplicities_pp :: Show t => [(t,Int)] -> String+multiplicities_pp =+  let f (x,y) = show x ++ "×" ++ show y+  in unwords . map f++-- | 'multiplicities' of 'P.primeFactors'.+--+-- > prime_factors_m 1 == []+-- > prime_factors_m 315 == [(3,2),(5,1),(7,1)]+prime_factors_m :: Integral i => i -> [(i,Int)]+prime_factors_m = multiplicities . P.primeFactors++-- | 'multiplicities_pp' of 'prime_factors_m'.+prime_factors_m_pp :: (Show i,Integral i) => i -> String+prime_factors_m_pp = multiplicities_pp . prime_factors_m++-- | Prime factors of /n/ and /d/.+rat_prime_factors :: Integral i => (i,i) -> ([i],[i])+rat_prime_factors = T.bimap1 P.primeFactors++-- | 'Ratio' variant of 'rat_prime_factors'+rational_prime_factors :: Integral i => Ratio i -> ([i],[i])+rational_prime_factors = rat_prime_factors . T.rational_nd++{- | Variant that writes factors of numerator as positive and factors for denominator as negative.+     Sorted by absolute value.++> rat_prime_factors_sgn (3 * 5 * 7 * 11,1) == [3,5,7,11]+> rat_prime_factors_sgn (3 * 5,7 * 11) == [3,5,-7,-11]+> rat_prime_factors_sgn (3 * 7,5) == [3,-5,7]+-}+rat_prime_factors_sgn :: Integral i => (i,i) -> [i]+rat_prime_factors_sgn r = let (n,d) = rat_prime_factors r in sortOn abs (n ++ map negate d)++-- | Rational variant.+rational_prime_factors_sgn :: Integral i => Ratio i -> [i]+rational_prime_factors_sgn = rat_prime_factors_sgn . T.rational_nd++-- | The largest prime factor of n/d.+rat_prime_limit :: Integral i => (i,i) -> i+rat_prime_limit = uncurry max . T.bimap1 prime_limit++-- | The largest prime factor of /n/.+--+-- > rational_prime_limit (243/125) == 5+rational_prime_limit :: Integral i => Ratio i -> i+rational_prime_limit = rat_prime_limit . T.rational_nd++-- | Merge function for 'rat_prime_factors_m'+rat_pf_merge :: Ord t => [(t,Int)] -> [(t,Int)] -> [(t,Int)]+rat_pf_merge p q =+  case (p,q) of+    (_,[]) -> p+    ([],_) -> map (\(i,j) -> (i,-j)) q+    ((a,b):p',(c,d):q') ->+      if a < c+      then (a,b) : rat_pf_merge p' q+      else if a > c+           then (c,-d) : rat_pf_merge p q'+           else if b /= d+                then (a,b-d) : rat_pf_merge p' q'+                else rat_pf_merge p' q'++{- | Collect the prime factors in a rational number given as a+numerator/ denominator pair (n,m). Prime factors are listed in+ascending order with their positive or negative multiplicities,+depending on whether the prime factor occurs in the numerator or the+denominator (after cancelling out common factors).++> rat_prime_factors_m (1,1) == []+> rat_prime_factors_m (16,15) == [(2,4),(3,-1),(5,-1)]+> rat_prime_factors_m (10,9) == [(2,1),(3,-2),(5,1)]+> rat_prime_factors_m (81,64) == [(2,-6),(3,4)]+> rat_prime_factors_m (27,16) == [(2,-4),(3,3)]+> rat_prime_factors_m (12,7) == [(2,2),(3,1),(7,-1)]+-}+rat_prime_factors_m :: Integral i => (i,i) -> [(i,Int)]+rat_prime_factors_m (n,d) = rat_pf_merge (prime_factors_m n) (prime_factors_m d)++-- | 'Ratio' variant of 'rat_prime_factors_m'+rational_prime_factors_m :: Integral i => Ratio i -> [(i,Int)]+rational_prime_factors_m = rat_prime_factors_m . T.rational_nd++-- | Variant of 'rational_prime_factors_m' giving results in a list.+--+-- > rat_prime_factors_l (1,1) == []+-- > rat_prime_factors_l (2^5,9) == [5,-2]+-- > rat_prime_factors_l (2*2*3,7) == [2,1,0,-1]+-- > rat_prime_factors_l (3*3,11*13) == [0,2,0,0,-1,-1]+rat_prime_factors_l :: Integral i => (i,i) -> [Int]+rat_prime_factors_l x =+  case rat_prime_factors_m x of+    [] -> []+    r -> let lm = maximum (map fst r)+         in map (\i -> fromMaybe 0 (lookup i r)) (T.take_until (== lm) P.primes)++-- | 'Ratio' variant of 'rat_prime_factors_l'+--+-- > rational_prime_factors_l (256/243) == [8,-5]+rational_prime_factors_l :: Integral i => Ratio i -> [Int]+rational_prime_factors_l = rat_prime_factors_l . T.rational_nd++-- | Variant of 'rational_prime_factors_l' padding table to /k/ places.+--   It is an error for /k/ to indicate a prime less than the limit of /x/.+--+-- > rat_prime_factors_t 6 (12,7) == [2,1,0,-1,0,0]+-- > rat_prime_factors_t 3 (9,7) == undefined+rat_prime_factors_t :: (Integral i,Show i) => Int -> (i,i) -> [Int]+rat_prime_factors_t k = T.pad_right_err 0 k . rat_prime_factors_l++-- | 'Ratio' variant of 'rat_prime_factors_t'+rational_prime_factors_t :: (Integral i,Show i) => Int -> Ratio i -> [Int]+rational_prime_factors_t n = rat_prime_factors_t n . T.rational_nd
Music/Theory/Maybe.hs view
@@ -76,9 +76,3 @@ 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
Music/Theory/Meter/Barlow_1987.hs view
@@ -3,53 +3,55 @@ -- Translated by Henning Lohner. module Music.Theory.Meter.Barlow_1987 where -import Data.List-import Data.Numbers.Primes {- primes -}+import Data.List {- base -} --import Debug.Trace -import Music.Theory.Math (R)+import qualified Data.Numbers.Primes as P {- primes -} +import qualified Music.Theory.Math as T {- hmt -}+ traceShow :: a -> b -> b traceShow _ x = x  -- | One indexed variant of 'genericIndex'. ----- > map (at [11..13]) [1..3] == [11,12,13]-at :: (Integral n) => [a] -> n -> a-at x i = x `genericIndex` (i - 1)+-- > map (at1 [11..13]) [1..3] == [11,12,13]+at1 :: Integral n => [a] -> n -> a+at1 x i = x `genericIndex` (i - 1) --- | Variant of 'at' with boundary rules and specified error message.+-- | Variant of 'at1' with boundary rules and specified error message. ----- > map (at' 'x' [11..13]) [0..4] == [1,11,12,13,1]--- > at' 'x' [0] 3 == undefined-at' :: (Num a,Show a,Integral n,Show n,Show m) => m -> [a] -> n -> a-at' m x i =+-- > map (at1_bnd_err 'x' [11..13]) [0..4] == [1,11,12,13,1]+-- > at1_bnd_err 'x' [0] 3 == undefined+at1_bnd_err :: (Num a,Show a,Integral n,Show n,Show m) => m -> [a] -> n -> a+at1_bnd_err m x i =     let n = genericLength x     in if i == 0 || i == n + 1        then 1 -- error (show ("at':==",m,x,i))        else if i < 0 || i > n + 1-            then error (show ("at'",m,x,i))+            then error (show ("at1_bnd_err",m,x,i))             else x `genericIndex` (i - 1)  -- | Variant of 'mod' with input constraints. ----- > mod' (-1) 2 == 1-mod' :: (Integral a,Show a) => a -> a -> a-mod' a b =+-- > mod_pos_err (-1) 2 == 1+-- > mod_pos_err 1 (-2) == undefined+mod_pos_err :: (Integral a,Show a) => a -> a -> a+mod_pos_err a b =     let r = mod a b     in if r < 0 || r >= b-       then error (show ("mod'",a,b,r))+       then error (show ("mod_pos_err",a,b,r))        else r --- | Specialised variant of 'fromIntegral'.-to_r :: Integral n => n -> R+-- | Type-specialised variant of 'fromIntegral'.+to_r :: Integral n => n -> Double to_r = fromIntegral  -- | Variant on 'div' with input constraints.-div' :: (Integral a,Show a) => String -> a -> a -> a-div' m i j =+div_pos_err :: (Integral a,Show a) => String -> a -> a -> a+div_pos_err m i j =     if i < 0 || j < 0-    then error (show ("div'",m,i,j))+    then error (show ("div_pos_err",m,i,j))     else truncate (to_r i / to_r j)  -- | A stratification is a tree of integral subdivisions.@@ -76,23 +78,24 @@ lower_psi q z n =     let s8 r =             let s1 = product q-                s2 = (n - 2) `mod'` s1-                s3 = let f k = at' "s3" q (z + 1 - k)+                s2 = (n - 2) `mod_pos_err` s1+                s3 = let f k = at1_bnd_err "s3" q (z + 1 - k)                      in product (map f [0 .. r])-                s4 = 1 + div' "s4" s2 s3-                c = at' "c" q (z - r)-                s5 = s4 `mod'` c+                s4 = 1 + div_pos_err "s4" s2 s3+                c = at1_bnd_err "c" q (z - r)+                s5 = s4 `mod_pos_err` c                 s6 = upper_psi c (1 + s5)-                s7 = let f = at' "s7" q+                s7 = let f = at1_bnd_err "s7" q                      in product (map f [0 .. z - r - 1])             in traceShow ("lower_psi:s",s1,s2,s3,s4,s5,s6,s7) (s7 * s6)     in traceShow ("lower_psi",q,z,n) (sum (map s8 [0 .. z - 1])) --- | The first /n/th primes, reversed.+-- | The first /n/ primes, reversed. -- -- > reverse_primes 14 == [43,41,37,31,29,23,19,17,13,11,7,5,3,2]+-- > length (reverse_primes 14) == 14 reverse_primes :: Integral n => n -> [n]-reverse_primes n = reverse (genericTake n primes)+reverse_primes n = reverse (genericTake n P.primes)  -- | Generate prime stratification for /n/. --@@ -105,7 +108,7 @@     let go x k =             case x of               p:x' -> if k `rem` p == 0-                      then p : go x (div' "ps" k p)+                      then p : go x (div_pos_err "ps" k p)                       else go x' k               [] -> []     in go (reverse_primes 14)@@ -125,8 +128,8 @@     else if p == 2          then p - n          else if n == p - 1-              then div' "upper_psi" p 4-              else let n' = n - div' "n'" n p+              then div_pos_err "upper_psi" p 4+              else let n' = n - div_pos_err "n'" n p                        s = prime_stratification (p - 1)                        q = lower_psi s (genericLength s) n'                        q' = to_r q@@ -179,7 +182,7 @@ -- @(0,1)@. -- -- relative_indispensibilities [3,2] == [1,0,0.6,0.2,0.8,0.4]-relative_indispensibilities :: (Integral n,Show n) => Stratification n -> [R]+relative_indispensibilities :: (Integral n,Show n) => Stratification n -> [Double] relative_indispensibilities = relative_to_length . indispensibilities  -- | Align two meters (given as stratifications) to least common@@ -209,7 +212,7 @@ -- | Type pairing a stratification and a tempo. type S_MM t = ([t],t) --- | Variant of 'div' that requires 'mod' be @0@.+-- | Variant of 'div' that requires 'mod_pos_err be @0@. whole_div :: Integral a => a -> a -> a whole_div i j =     case i `divMod` j of@@ -242,18 +245,6 @@         s2' = s2 ++ prime_stratification (t `whole_div` t2)     in (s1',s2') --- | Arithmetic mean (average) of a list.------ > mean [0..5] == 2.5-mean :: Fractional a => [a] -> a-mean x = sum x / fromIntegral (length x)---- | Square of /n/.------ > square 5 == 25-square :: Num a => a -> a-square n = n * n- -- | Composition of 'prolong_stratifications' and 'align_meters'. -- -- > align_s_mm indispensibilities ([2,2,3],5) ([3,5],4)@@ -274,15 +265,15 @@ upper_psi' h n =     if h > 3     then let omega x = if x == 0 then 0 else 1-             h4 = div' "h4" h 4+             h4 = div_pos_err "h4" h 4              n' = n - 1 + omega (h - n)              p = prime_stratification (h - 1)              x0 = lower_psi p (genericLength p) n'-             x1 = x0 + omega (div' "z" x0 h4)+             x1 = x0 + omega (div_pos_err "z" x0 h4)              x2 = omega (h - n - 1)              x3 = x2 + h4 * (1 - x2)          in traceShow ("upper_psi'",h,n,n',x0,x1,x2,x3) (x1 * x3)-    else (h + n - 2) `mod'` h+    else (h + n - 2) `mod_pos_err` h  -- | The /MPS/ limit equation given on p.58. --@@ -301,9 +292,9 @@ -- > mean_square_product [(2,3),(4,5)] == (6^2 + 20^2) / 2^2 mean_square_product :: Fractional n => [(n,n)] -> n mean_square_product x =-    let f = square . uncurry (*)+    let f = T.square . uncurry (*)         n = fromIntegral (length x)-    in sum (map f x) / square n+    in sum (map f x) / T.square n  -- | An incorrect attempt at the description in paragraph two of p.58 -- of the /CMJ/ paper.@@ -311,7 +302,7 @@ -- > let p ~= q = abs (p - q) < 1e-4 -- > metrical_affinity [2,3] 1 [3,2] 1 ~= 0.0324 -- > metrical_affinity [2,2,3] 20 [3,5] 16 ~= 0.0028-metrical_affinity :: (Integral n,Show n) => [n] -> n -> [n] -> n -> R+metrical_affinity :: (Integral n,Show n) => [n] -> n -> [n] -> n -> Double metrical_affinity s1 v1 s2 v2 =     let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2)         i1 = relative_indispensibilities s1'@@ -331,7 +322,7 @@ -- > metrical_affinity' [2,2,2] 1 [3,2,2] 1 ~= 0.45872 -- -- > metrical_affinity' [3,2,2] 3 [2,2,3] 2 ~= 0.10282-metrical_affinity' :: (Integral t,Show t) => [t] -> t -> [t] -> t -> R+metrical_affinity' :: (Integral t,Show t) => [t] -> t -> [t] -> t -> Double metrical_affinity' s1 v1 s2 v2 =     let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2)         ix :: (Integer -> x) -> Integer -> x@@ -339,20 +330,20 @@                    1 -> f 1                    2 -> f 2                    _ -> error (show ("ix",i))-        s = ix (at [s1,s2])-        v = ix (at [v1,v2])+        s = ix (at1 [s1,s2])+        v = ix (at1 [v1,v2])         u = ix (genericLength . s)-        s' = ix (at [s1',s2'])+        s' = ix (at1 [s1',s2'])         z = ix (genericLength . s')-        q i j = s i `at` j+        q i j = s i `at1` j         omega_u i = product (map (q i) [1::Int .. u i])         omega_z _ = lcm (v 1 * omega_u 1) (v 2 * omega_u 2)         omega_0 = lcm (product (s' 1)) (product (s' 2))-        x0 n i = lower_psi (s' i) (z i) (1 + ((n - 1) `mod'` omega_z i))-        x1 n = square (product (map (x0 n) [1,2]))+        x0 n i = lower_psi (s' i) (z i) (1 + ((n - 1) `mod_pos_err` omega_z i))+        x1 n = T.square (product (map (x0 n) [1,2]))         x2 = sum (map x1 [1 .. omega_0])         x3 = 18 * x2 - 2-        x4 i = square (omega_z i - 1)+        x4 i = T.square (omega_z i - 1)         x5 = product (map x4 [1::Integer,2])         x6 = 7 * omega_0 * x5         x7 = to_r x3 / to_r x6
Music/Theory/Metric/Buchler_1998.hs view
@@ -3,13 +3,14 @@ -- thesis, University of Rochester, 1998 module Music.Theory.Metric.Buchler_1998 where +import Data.Int {- base -} 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.Z as T+import qualified Music.Theory.Z.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@@ -18,7 +19,7 @@ -- | Set classes of cardinality /n/. -- -- > sc_table_n 2 == [[0,1],[0,2],[0,3],[0,4],[0,5],[0,6]]-sc_table_n :: (Integral n) => n -> [[Z12]]+sc_table_n :: (Integral n) => n -> [[Int8]] sc_table_n n = filter (of_c n) (map snd T.sc_table)  -- | Minima and maxima of ICV of SCs of cardinality /n/.@@ -27,7 +28,7 @@ icv_minmax :: (Integral n, Integral b) => n -> ([b], [b]) icv_minmax n =     let t = sc_table_n n-        i = transpose (map T.icv t)+        i = transpose (map (T.z_icv T.z12) t)     in (map minimum i,map maximum i)  data R = MIN | MAX deriving (Eq,Show)@@ -43,10 +44,10 @@       MAX -> "-"  -- | 'SATV' element measure with given funtion.-satv_f :: (Integral n) => ((n,n,n) -> D n) -> [Z12] -> [D n]+satv_f :: (Integral n) => ((n,n,n) -> D n) -> [Int8] -> [D n] satv_f f p =     let n = length p-        i = T.icv p+        i = T.z_icv T.z12 p         (l,r) = icv_minmax n     in map f (zip3 l i r) @@ -68,7 +69,7 @@ -- -- > satv_e_pp (satv_a [0,1,2,6,7,8]) == "<-1,+2,+0,+0,-1,-0>" -- > satv_e_pp (satv_a [0,1,2,3,4]) == "<-0,-1,-2,+0,+0,+0>"-satv_a :: Integral i => [Z12] -> [D i]+satv_a :: Integral i => [Int8] -> [D i] satv_a =     let f (l,i,r) = let l' = abs (i - l)                         r' = abs (i - r)@@ -81,7 +82,7 @@ -- -- > satv_e_pp (satv_b [0,1,2,6,7,8]) == "<+4,-4,-5,-4,+4,+3>" -- > satv_e_pp (satv_b [0,1,2,3,4]) == "<+4,+3,+2,-3,-4,-2>"-satv_b :: Integral i => [Z12] -> [D i]+satv_b :: Integral i => [Int8] -> [D i] satv_b =     let f (l,i,r) = let l' = abs (i - l)                         r' = abs (i - r)@@ -102,7 +103,7 @@ -- > satv_pp (satv [0,1,2,3,4,6]) == "(<-1,-2,-2,+0,+1,+1>,<+4,+4,+3,-4,-4,-2>)" -- > satv_pp (satv [0,1,3,6,8]) == "(<+1,-2,-2,+0,-1,-1>,<-3,+2,+2,-3,+3,+1>)" -- > satv_pp (satv [0,2,3,5,7,9]) == "(<+1,-2,-2,+0,-1,+1>,<-4,+4,+3,-4,+4,-2>)"-satv :: Integral i => [Z12] -> SATV i+satv :: Integral i => [Int8] -> SATV i satv p = (satv_a p,satv_b p)  -- | 'SATV' reorganised by 'R'.@@ -120,7 +121,7 @@ -- | Sum of numerical components of @a@ and @b@ parts of 'SATV'. -- -- > satv_n_sum (satv [0,1,2,6,7,8]) == [5,6,5,4,5,3]--- > satv_n_sum (satv [0,3,6,9]) = [3,3,4,3,3,2]+-- > satv_n_sum (satv [0,3,6,9]) == [3,3,4,3,3,2] satv_n_sum :: Num c => SATV c -> [c] satv_n_sum (i,j) = zipWith (+) (map snd i) (map snd j) @@ -148,7 +149,7 @@ -- > satsim [0,1,2,3,4] [0,1,4,5,7] == 8/21 -- > satsim [0,1,2,3,4] [0,2,4,6,8] == 4/7 -- > satsim [0,1,4,5,7] [0,2,4,6,8] == 4/7-satsim :: Integral a => [Z12] -> [Z12] -> Ratio a+satsim :: Integral a => [Int8] -> [Int8] -> Ratio a satsim p q =     let i = satv p         j = satv q@@ -161,7 +162,7 @@ -- | Table of 'satsim' measures for all @SC@ pairs. -- -- > length satsim_table == 24310-satsim_table :: Integral i => [(([Z12],[Z12]),Ratio i)]+satsim_table :: Integral i => [(([Int8],[Int8]),Ratio i)] satsim_table =     let f (i,j) = ((i,j),satsim i j)         t = filter ((`notElem` [0,1,12]) . length) (map snd T.sc_table)
Music/Theory/Metric/Morris_1980.hs view
@@ -2,19 +2,21 @@ -- Sets\". Perspectives of New Music, 18(2):445-460, 1980. module Music.Theory.Metric.Morris_1980 where -import Data.Ratio-import Music.Theory.Z12-import Music.Theory.Z12.Forte_1973+import Data.Int {- base -}+import Data.Ratio {- base -} +import Music.Theory.Z {- hmt -}+import Music.Theory.Z.Forte_1973 {- hmt -}+ -- | SIM ----- > icv [0,1,3,6] == [1,1,2,0,1,1] && icv [0,2,4,7] == [0,2,1,1,2,0]+-- > icv 12 [0,1,3,6] == [1,1,2,0,1,1] && icv 12 [0,2,4,7] == [0,2,1,1,2,0] -- > sim [0,1,3,6] [0,2,4,7] == 6 -- > sim [0,1,2,4,5,8] [0,1,3,7] == 9-sim :: Integral a => [Z12] -> [Z12] -> a+sim :: Integral a => [Int8] -> [Int8] -> a sim r s =-    let r' = icv r-        s' = icv s+    let r' = z_icv z12 r+        s' = z_icv z12 s         t = zipWith (-) r' s'     in sum (map abs t) @@ -25,8 +27,8 @@ -- > asim [0,1,2,3,4] [0,1,4,5,7] == 2/5 -- > asim [0,1,2,3,4] [0,2,4,6,8] == 3/5 -- > asim [0,1,4,5,7] [0,2,4,6,8] == 3/5-asim :: (Integral n) => [Z12] -> [Z12] -> Ratio n+asim :: (Integral n) => [Int8] -> [Int8] -> Ratio n asim r s =-    let r' = icv r-        s' = icv s+    let r' = z_icv z12 r+        s' = z_icv z12 s     in sim r s % (sum r' + sum s')
Music/Theory/Metric/Polansky_1996.hs view
@@ -1,15 +1,15 @@--- | Larry Polansky. \"Morphological Metrics\". Journal of New Music--- Research, 25(4):289-368, 1996.+-- | Larry Polansky. \"Morphological Metrics\".+-- Journal of New Music Research, 25(4):289-368, 1996. module Music.Theory.Metric.Polansky_1996 where -import Data.List-import Data.Maybe-import Data.Ratio-import qualified Music.Theory.Contour.Polansky_1992 as C-import qualified Music.Theory.List as L+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -} --- | Distance function, ordinarily /n/ below is in 'Num', 'Fractional'--- or 'Real'.+import qualified Music.Theory.Contour.Polansky_1992 as C {- hmt -}+import qualified Music.Theory.List as L {- hmt -}++-- | Distance function, ordinarily /n/ below is in 'Num', 'Fractional' or 'Real'. type Interval a n = (a -> a -> n)  -- | 'fromIntegral' '.' '-'.@@ -21,43 +21,43 @@ dif_r i j = realToFrac (i - j)  -- | 'abs' '.' /f/.-abs_dif :: Num n => Interval a n -> a -> a -> n-abs_dif f i j = abs (i `f` j)+abs_of :: Num n => Interval a n -> a -> a -> n+abs_of f i j = abs (i `f` j)  -- | Square. sqr :: Num a => a -> a sqr n = n * n  -- | 'sqr' '.' /f/.-sqr_dif :: Num n => Interval a n -> a -> a -> n-sqr_dif f i j = sqr (i `f` j)+sqr_of :: Num n => Interval a n -> a -> a -> n+sqr_of f i j = sqr (i `f` j)  -- | 'sqr' '.' 'abs' '.' /f/.-sqr_abs_dif :: Num n => Interval a n -> a -> a -> n-sqr_abs_dif f i = sqr . abs_dif f i+sqr_abs_of :: Num n => Interval a n -> a -> a -> n+sqr_abs_of f i = sqr . abs_of f i  -- | 'sqrt' '.' 'abs' '.' /f/.-sqrt_abs_dif :: Floating c => Interval a c -> a -> a -> c-sqrt_abs_dif f i = sqrt . abs_dif f i+sqrt_abs_of :: Floating c => Interval a c -> a -> a -> c+sqrt_abs_of f i = sqrt . abs_of f i  -- | City block metric, p.296 -- -- > city_block_metric (-) (1,2) (3,5) == 2+3 city_block_metric :: Num n => Interval a n -> (a,a) -> (a,a) -> n-city_block_metric f (x1,x2) (y1,y2) = abs_dif f x1 y1 + abs_dif f x2 y2+city_block_metric f (x1,x2) (y1,y2) = abs_of f x1 y1 + abs_of f x2 y2  -- | Two-dimensional euclidean metric, p.297. -- -- > euclidean_metric_2 (-) (1,2) (3,5) == sqrt (4+9) euclidean_metric_2 :: Floating n => Interval a n -> (a,a) -> (a,a) -> n-euclidean_metric_2 f (x1,x2) (y1,y2) = sqrt (sqr_dif f x1 y1 + sqr_dif f x2 y2)+euclidean_metric_2 f (x1,x2) (y1,y2) = sqrt (sqr_of f x1 y1 + sqr_of f x2 y2)  -- | /n/-dimensional euclidean metric -- -- > euclidean_metric_l (-) [1,2] [3,5] == sqrt (4+9) -- > euclidean_metric_l (-) [1,2,3] [2,4,6] == sqrt (1+4+9) euclidean_metric_l :: Floating c => Interval b c -> [b] -> [b] -> c-euclidean_metric_l f p = sqrt . sum . zipWith (sqr_dif f) p+euclidean_metric_l f p = sqrt . sum . zipWith (sqr_of f) p  -- | Cube root. --@@ -89,19 +89,12 @@     let g i j = abs (i `f` j) ** n     in nthrt n (sum (zipWith g p q)) --- | Integration with /f/.------ > d_dx (-) [0,2,4,1,0] == [2,2,-3,-1]--- > d_dx (-) [2,3,0,4,1] == [1,-3,4,-3]-d_dx :: Interval a n -> [a] -> [n]-d_dx f l = zipWith f (tail l) l---- | 'map' 'abs' '.' 'd_dx'.+-- | 'map' 'abs' '.' 'L.d_dx_by'. -- -- > d_dx_abs (-) [0,2,4,1,0] == [2,2,3,1] -- > d_dx_abs (-) [2,3,0,4,1] == [1,3,4,3] d_dx_abs :: Num n => Interval a n -> [a] -> [n]-d_dx_abs f = map abs . d_dx f+d_dx_abs f = map abs . L.d_dx_by f  -- | Ordered linear magnitude (no delta), p.300 --@@ -114,11 +107,11 @@  -- | Ordered linear magintude (general form) p.302 ----- > olm_general (abs_dif (-)) [0,2,4,1,0] [2,3,0,4,1] == 1.25--- > olm_general (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6+-- > olm_general (abs_of (-)) [0,2,4,1,0] [2,3,0,4,1] == 1.25+-- > olm_general (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6 olm_general :: Fractional n => Interval a n -> [a] -> [a] -> n olm_general f p q =-    let r = zipWith (-) (d_dx f p) (d_dx f q)+    let r = zipWith (-) (L.d_dx_by f p) (L.d_dx_by f q)         z = sum (map abs r)     in z / (fromIntegral (length p) - 1) @@ -149,8 +142,8 @@  -- | Ordered linear magintude (generalised-interval form) p.305 ----- > olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6--- > olm (abs_dif dif_r) (abs_ix_dif dif_r) maximum [1,5,12,2,9,6] [7,6,4,9,8,1] == 0.46+-- > olm (abs_of dif_r) (abs_ix_dif dif_r) (const 1) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6+-- > olm (abs_of dif_r) (abs_ix_dif dif_r) maximum [1,5,12,2,9,6] [7,6,4,9,8,1] == 0.46 olm :: Fractional a => Psi a -> Delta n a  -> ([a] -> a) -> [n] -> [n] -> a olm psi delta maxint m n =     let l = length m@@ -163,11 +156,11 @@ -- > olm_no_delta [0,2,4,1,0] [2,3,0,4,1] == 1.25 -- > olm_no_delta [1,6,2,5,11] [3,15,13,2,9] == 4.5 olm_no_delta :: (Real a,Real n,Fractional n) => [a] -> [a] -> n-olm_no_delta = olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1)+olm_no_delta = olm (abs_of dif_r) (abs_ix_dif dif_r) (const 1)  -- > olm_no_delta_squared [0,2,4,1,0] [2,3,0,4,1] == sum (map sqrt [3,5,7,8]) / 4 olm_no_delta_squared :: Floating a => [a] -> [a] -> a-olm_no_delta_squared = olm (sqrt_abs_dif (-)) (sqr_abs_ix_dif (-)) (const 1)+olm_no_delta_squared = olm (sqrt_abs_of (-)) (sqr_abs_ix_dif (-)) (const 1)  second_order :: (Num n) => ([n] -> [n] -> t) -> [n] -> [n] -> t second_order f p q = f (d_dx_abs (-) p) (d_dx_abs (-) q)@@ -187,12 +180,12 @@ second_order_binonial_coefficient :: Fractional a => a -> a second_order_binonial_coefficient n = ((n * n) - n) / 2 --- | 'd_dx' of 'flip' 'compare'.+-- | 'L.d_dx_by' of 'flip' 'compare'. -- -- > direction_interval [5,9,3,2] == [LT,GT,GT] -- > direction_interval [2,5,6,6] == [LT,LT,EQ] direction_interval :: Ord i => [i] -> [Ordering]-direction_interval = d_dx (flip compare)+direction_interval = L.d_dx_by (flip compare)  -- | Histogram of list of 'Ordering's. --@@ -219,7 +212,7 @@     let (i,j,k) = direction_vector m         (p,q,r) = direction_vector n         z = (i + j + k) * 2-    in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z+    in (abs_of (-) i p + abs_of (-) j q + abs_of (-) k r) % z  -- | Ordered linear direction, p.312 --@@ -256,27 +249,24 @@     let (i,j,k) = ord_hist (concat (C.half_matrix_f compare m))         (p,q,r) = ord_hist (concat (C.half_matrix_f compare n))         z = (i + j + k) * 2-    in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z+    in (abs_of (-) i p + abs_of (-) j q + abs_of (-) k r) % z  -- | 'C.half_matrix_f', Fig.9, p.318 ----- > let r = [[2,3,1,4]--- >           ,[1,3,6]--- >             ,[4,7]--- >               ,[3]]--- > in combinatorial_magnitude_matrix (abs_dif (-)) [5,3,2,6,9] == r+-- > let r = [[2,3,1,4],[1,3,6],[4,7],[3]]+-- > combinatorial_magnitude_matrix (abs_of (-)) [5,3,2,6,9] == r combinatorial_magnitude_matrix :: Interval a n -> [a] -> [[n]] combinatorial_magnitude_matrix = C.half_matrix_f  -- | Unordered linear magnitude (simplified), p.320-321 -- -- > let r = abs (sum [5,4,3,6] - sum [12,2,11,7]) / 4--- > in ulm_simplified (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == r+-- > ulm_simplified (abs_of (-)) [1,6,2,5,11] [3,15,13,2,9] == r ----- > ulm_simplified (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3+-- > ulm_simplified (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3 ulm_simplified :: Fractional n => Interval a n -> [a] -> [a] -> n ulm_simplified f p q =-    let g = abs . sum . d_dx f+    let g = abs . sum . L.d_dx_by f     in abs (g p - g q) / fromIntegral (length p - 1)  ocm_zcm :: Fractional n => Interval a n -> [a] -> [a] -> (n, n, [n])@@ -291,8 +281,8 @@  -- | Ordered combinatorial magnitude (OCM), p.323 ----- > ocm (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 5.2--- > ocm (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3.6+-- > ocm (abs_of (-)) [1,6,2,5,11] [3,15,13,2,9] == 5.2+-- > ocm (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3.6 ocm :: Fractional n => Interval a n -> [a] -> [a] -> n ocm f p q =     let (z,c,_) = ocm_zcm f p q@@ -300,8 +290,8 @@  -- | Ordered combinatorial magnitude (OCM), p.323 ----- > ocm_absolute_scaled (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 0.4--- > ocm_absolute_scaled (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 54/(15*11)+-- > ocm_absolute_scaled (abs_of (-)) [1,6,2,5,11] [3,15,13,2,9] == 0.4+-- > ocm_absolute_scaled (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 54/(15*11) ocm_absolute_scaled :: (Ord n,Fractional n) => Interval a n -> [a] -> [a] -> n ocm_absolute_scaled f p q =     let (z,c,m) = ocm_zcm f p q
Music/Theory/Monad.hs view
@@ -1,10 +1,22 @@ -- | Monad functions. module Music.Theory.Monad where -repeatM_ :: (Monad m) => m a -> m ()+-- | 'sequence_' of 'repeat'.+repeatM_ :: Monad m => m a -> m () repeatM_ = sequence_ . repeat -iterateM_ :: (Monad m) => st -> (st -> m st) -> m ()-iterateM_ st f = do+-- | Monadic variant of 'iterate'.+iterateM_ :: Monad m => (st -> m st) -> st -> m ()+iterateM_ f st = do   st' <- f st-  iterateM_ st' f+  iterateM_ f st'++-- | 'fmap' of 'concat' of 'mapM'+concatMapM :: Monad m => (t -> m [u]) -> [t] -> m [u]+concatMapM f = fmap concat . mapM f++-- | If i then j else k.+m_if :: Monad m => (m Bool,m t,m t) -> m t+m_if (i,j,k) = do+  r <- i+  if r then j else k
+ Music/Theory/Opt.hs view
@@ -0,0 +1,146 @@+{- | Very simple CLI option parser.++Only allows options of the form --key=value, with the form --key equal to --key=True.++A list of OPT_USR describes the options and provides default values.++'get_opt_arg' merges user and default values into a table with values for all options.++To fetch options use 'opt_get' and 'opt_read'.++-}+module Music.Theory.Opt where++import Control.Monad {- base -}+import Data.Either {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import System.Environment {- base -}+import System.Exit {- base -}++import qualified Data.List.Split as Split {- split -}++import qualified Music.Theory.Read as T {- hmt -}++-- | (KEY,VALUE)+--   Key does not include leading '--'.+type OPT = (String,String)++-- | (KEY,DEFAULT-VALUE,TYPE,NOTE)+type OPT_USR = (String,String,String,String)++-- | Re-write default values at USR_OPT.+opt_usr_rw_def :: [OPT] -> [OPT_USR] -> [OPT_USR]+opt_usr_rw_def rw =+  let f (k,v,ty,dsc) = case lookup k rw of+                         Just v' -> (k,v',ty,dsc)+                         Nothing -> (k,v,ty,dsc)+  in map f++-- | OPT_USR to OPT.+opt_plain :: OPT_USR -> OPT+opt_plain (k,v,_,_) = (k,v)++-- | OPT_USR to help string, indent is two spaces.+opt_usr_help :: OPT_USR -> String+opt_usr_help (k,v,t,n) = concat ["  ",k,":",t," -- ",n,"; default=",v]++-- | 'unlines' of 'opt_usr_help'+opt_help :: [OPT_USR] -> String+opt_help = unlines . map opt_usr_help++-- | Lookup KEY in OPT, error if non-existing.+opt_get :: [OPT] -> String -> String+opt_get o k = fromMaybe (error ("opt_get: " ++ k)) (lookup k o)++-- | Variant that returns Nothing if the result is the empty string, else Just the result.+opt_get_nil :: [OPT] -> String -> Maybe String+opt_get_nil o k = let r = opt_get o k in if null r then Nothing else Just r++-- | 'read' of 'get_opt'+opt_read :: Read t => [OPT] -> String -> t+opt_read o = T.read_err . opt_get o++-- | Parse k or k=v string, else error.+opt_param_parse :: String -> OPT+opt_param_parse p =+  case Split.splitOn "=" p of+    [lhs] -> (lhs,"True")+    [lhs,rhs] -> (lhs,rhs)+    _ -> error ("opt_param_parse: " ++ p)++-- | Parse option string of form "--opt" or "--key=value".+--+-- > opt_parse "--opt" == Just ("opt","True")+-- > opt_parse "--key=value" == Just ("key","value")+opt_parse :: String -> Maybe OPT+opt_parse s =+  case s of+    '-':'-':p -> Just (opt_param_parse p)+    _ -> Nothing++-- | Parse option sequence, collating options and non-options.+--+-- > opt_set_parse (words "--a --b=c d") == ([("a","True"),("b","c")],["d"])+opt_set_parse :: [String] -> ([OPT],[String])+opt_set_parse =+  let f s = maybe (Right s) Left (opt_parse s)+  in partitionEithers . map f++-- | Left-biased OPT merge.+opt_merge :: [OPT] -> [OPT] -> [OPT]+opt_merge p q =+  let x = map fst p+  in p ++ filter (\(k,_) -> k `notElem` x) q++-- | Process argument list.+opt_proc :: [OPT_USR] -> [String] -> ([OPT], [String])+opt_proc def arg =+  let (o,a) = opt_set_parse arg+  in (opt_merge o (map opt_plain def),a)++-- | Usage text+type OPT_USG = [String]++-- | Print usage pre-amble and 'opt_help'.+opt_usage :: OPT_USG -> [OPT_USR] -> IO ()+opt_usage usg def = putStrLn (unlines (usg ++ ["",opt_help def])) >> exitWith ExitSuccess++-- | Verify that all OPT have keys that are in OPT_USR+opt_verify :: OPT_USG -> [OPT_USR] -> [OPT] -> IO ()+opt_verify usg def =+  let k_set = map (fst . opt_plain) def+      f (k,_) = if k `elem` k_set+                then return ()+                else putStrLn ("UNKNOWN KEY: " ++ k ++ "\n") >> opt_usage usg def+  in mapM_ f++-- | 'opt_set_parse' and maybe 'opt_verify' and 'opt_merge' of 'getArgs'.+--   If arguments include -h or --help run 'opt_usage'+opt_get_arg :: Bool -> OPT_USG -> [OPT_USR] -> IO ([OPT],[String])+opt_get_arg chk usg def = do+  a <- getArgs+  when ("-h" `elem` a || "--help" `elem` a) (opt_usage usg def)+  let (o,p) = opt_set_parse a+  when chk (opt_verify usg def o)+  return (opt_merge o (map opt_plain def),p)++-- | Parse param set, one parameter per line.+--+-- > opt_param_set_parse "a\nb=c" == [("a","True"),("b","c")]+opt_param_set_parse :: String -> [OPT]+opt_param_set_parse = map opt_param_parse . lines++-- | Simple scanner over argument list.+opt_scan :: [String] -> String -> Maybe String+opt_scan a k =+  let (o,_) = opt_set_parse a+  in fmap snd (find ((== k) . fst) o)++-- | Scanner with default value.+opt_scan_def :: [String] -> (String,String) -> String+opt_scan_def a (k,v) = fromMaybe v (opt_scan a k)++-- | Reading scanner with default value.+opt_scan_read :: Read t => [String] -> (String,t) -> t+opt_scan_read a (k,v) = maybe v read (opt_scan a k)
Music/Theory/Ord.hs view
@@ -1,6 +1,10 @@ -- | 'Ordering' functions module Music.Theory.Ord where +-- | Minimum by /f/.+min_by :: Ord a => (t -> a) -> t -> t -> t+min_by f p q = if f p <= f q then p else q+ -- | Specialised 'fromEnum'. ord_to_int :: Ordering -> Int ord_to_int = fromEnum
Music/Theory/Parse.hs view
@@ -2,7 +2,8 @@  import Data.Maybe {- base -} -import qualified Text.ParserCombinators.Parsec as P {- parsec -}+import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as P {- parsec -}  -- | A 'Char' parser. type P a = P.GenParser Char () a
Music/Theory/Permutations.hs view
@@ -2,9 +2,9 @@ module Music.Theory.Permutations where  import qualified Data.Permute as P {- permutation -}-import Numeric (showHex) {- base -}+import qualified Numeric {- base -} -import qualified Music.Theory.List as L+import qualified Music.Theory.List as L {- hmt -}  -- | Factorial function. --@@ -14,13 +14,14 @@  -- | Number of /k/ element permutations of a set of /n/ elements. ----- > (nk_permutations 4 3,nk_permutations 13 3) == (24,1716)+-- > let f = nk_permutations in (f 4 3,f 13 3,f 12 12) == (24,1716,479001600) nk_permutations :: Integral a => a -> a -> a nk_permutations n k = factorial n  `div` factorial (n - k)  -- | Number of /nk/ permutations where /n/ '==' /k/. -- -- > map n_permutations [1..8] == [1,2,6,24,120,720,5040,40320]+-- > n_permutations 12 == 479001600 -- > n_permutations 16 `div` 1000000 == 20922789 n_permutations :: (Integral a) => a -> a n_permutations n = nk_permutations n n@@ -28,7 +29,7 @@ -- | Generate the permutation from /p/ to /q/, ie. the permutation -- that, when applied to /p/, gives /q/. ----- > apply_permutation (permutation [0,1,3] [1,0,3]) [0,1,3] == [1,0,3]+-- > apply_permutation (permutation "abc" "bac") "abc" == "bac" permutation :: (Eq a) => [a] -> [a] -> P.Permute permutation p q =     let n = length p@@ -38,7 +39,7 @@ -- | Apply permutation /f/ to /p/. -- -- > let p = permutation [1..4] [4,3,2,1]--- > in apply_permutation p [1..4] == [4,3,2,1]+-- > apply_permutation p [1..4] == [4,3,2,1] apply_permutation :: P.Permute -> [a] -> [a] apply_permutation f p = map (p !!) (P.elems f) @@ -56,7 +57,7 @@ -- > non_invertible (permutation [0,1,3] [1,0,3]) == True -- -- > let p = permutation [1..4] [4,3,2,1]--- > in non_invertible p == True && P.cycles p == [[0,3],[1,2]]+-- > non_invertible p == True && P.cycles p == [[0,3],[1,2]] non_invertible :: P.Permute -> Bool non_invertible p = p == P.inverse p @@ -68,9 +69,8 @@  -- | Generate all permutations of size /n/. ----- > map one_line (permutations_n 3) == [[1,2,3],[1,3,2]--- >                                    ,[2,1,3],[2,3,1]--- >                                    ,[3,1,2],[3,2,1]]+-- > let r = [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]+-- > map one_line (permutations_n 3) == r permutations_n :: Int -> [P.Permute] permutations_n n =     let f p = let r = P.next p@@ -79,10 +79,10 @@  -- | Composition of /q/ then /p/. ----- > let {p = from_cycles [[0,2],[1],[3,4]]--- >     ;q = from_cycles [[0,1,4],[2,3]]--- >     ;r = p `compose` q}--- > in apply_permutation r [1,2,3,4,5] == [2,4,5,1,3]+-- > let p = from_cycles [[0,2],[1],[3,4]]+-- > let q = from_cycles [[0,1,4],[2,3]]+-- > let r = p `compose` q+-- > apply_permutation r [1,2,3,4,5] == [2,4,5,1,3] compose :: P.Permute -> P.Permute -> P.Permute compose p q =     let n = P.size q@@ -104,9 +104,8 @@ -- -- > one_line (permutation [0,1,3] [1,0,3]) == [2,1,3] ----- > map one_line (permutations_n 3) == [[1,2,3],[1,3,2]--- >                                    ,[2,1,3],[2,3,1]--- >                                    ,[3,1,2],[3,2,1]]+-- > let r = [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]+-- > map one_line (permutations_n 3) == r one_line :: P.Permute -> [Int] one_line = snd . two_line @@ -115,11 +114,11 @@ -- > one_line_compact (permutation [0,1,3] [1,0,3]) == "213" -- -- > let p = permutations_n 3--- > in unwords (map one_line_compact p) == "123 132 213 231 312 321"+-- > unwords (map one_line_compact p) == "123 132 213 231 312 321" one_line_compact :: P.Permute -> String one_line_compact =     let f n = if n >= 0 && n <= 15-              then showHex n ""+              then Numeric.showHex n ""               else error "one_line_compact:not(0-15)"     in concatMap f . one_line @@ -142,6 +141,7 @@     in map f ps  {-+ let q = permutation [1..4] [2,3,4,1] -- [[0,1,2,3]] (q,non_invertible q,P.cycles q,apply_permutation q [1..4]) @@ -154,9 +154,9 @@  map P.cycles (permutations_n 3) map P.cycles (permutations_n 4)-partition not (map non_invertible (permutations_n 4))  import Data.List {- base -}+partition not (map non_invertible (permutations_n 4)) putStrLn $ unlines $ map unwords $ permutations ["A0","A1","B0"]  -}
Music/Theory/Permutations/List.hs view
@@ -8,10 +8,10 @@  -- | Generate all permutations. ----- > permutations [0,3] == [[0,3],[3,0]]--- > length (permutations [1..5]) == P.n_permutations 5-permutations :: [a] -> [[a]]-permutations i =+-- > permutations_l [0,3] == [[0,3],[3,0]]+-- > length (permutations_l [1..5]) == P.n_permutations 5+permutations_l :: [a] -> [[a]]+permutations_l i =     let f p = P.apply_permutation p i     in map f (P.permutations_n (length i))
Music/Theory/Permutations/Morris_1984.hs view
@@ -5,7 +5,6 @@ -- <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 Data.Maybe {- base -}
Music/Theory/Pitch.hs view
@@ -5,19 +5,25 @@ import Data.Function {- base -} import Data.List {- base -} import Data.Maybe {- base -}+import Data.Word {- base -} import Text.Printf {- base -} +import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as P {- parsec -}+ import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Math as T {- hmt -} import qualified Music.Theory.Pitch.Note as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -} --- * Octave & pitch-class (generic)+-- * Octave pitch-class (generic)  -- | 'Octave' and 'PitchClass' duple. type Octave_PitchClass i = (i,i)  -- | Normalise 'Octave_PitchClass' value, ie. ensure pitch-class is in (0,11).-octave_pitchclass_nrm :: Integral i => Octave_PitchClass i -> Octave_PitchClass i+octave_pitchclass_nrm :: (Ord i,Num i) => Octave_PitchClass i -> Octave_PitchClass i octave_pitchclass_nrm (o,pc) =     if pc > 11     then octave_pitchclass_nrm (o+1,pc-12)@@ -28,18 +34,21 @@ -- | Transpose 'Octave_PitchClass' value. octave_pitchclass_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i octave_pitchclass_trs n (o,pc) =-    let pc' = fromIntegral pc-        k = pc' + n+    let k = pc + n         (i,j) = k `divMod` 12-    in (fromIntegral o + fromIntegral i,fromIntegral j)+    in (o + i,j)  -- | 'Octave_PitchClass' value to integral /midi/ note number.-octave_pitchclass_to_midi :: Integral i => Octave_PitchClass i -> i+--+-- > map octave_pitchclass_to_midi [(-1,9),(8,0)] == map (+ 9) [0,99]+octave_pitchclass_to_midi :: Num i => Octave_PitchClass i -> i octave_pitchclass_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc  -- | Inverse of 'octave_pitchclass_to_midi'.-midi_to_octave_pitchclass :: Integral i => i -> Octave_PitchClass i-midi_to_octave_pitchclass n = (n - 12) `divMod` 12+--+-- > map midi_to_octave_pitchclass [0,36,60,84,91] == [(-1,0),(2,0),(4,0),(6,0),(6,7)]+midi_to_octave_pitchclass :: (Integral m,Integral i) => m -> Octave_PitchClass i+midi_to_octave_pitchclass n = (fromIntegral n - 12) `divMod` 12  -- * Octave & PitchClass @@ -53,8 +62,8 @@ type OctPC = (Octave,PitchClass)  -- | Translate from generic octave & pitch-class duple.-to_octpc :: (Integral pc, Integral oct) => (oct,pc) -> OctPC-to_octpc (oct,pc) = (fromIntegral oct,fromIntegral pc)+octave_pitchclass_to_octpc :: (Integral pc, Integral oct) => (oct,pc) -> OctPC+octave_pitchclass_to_octpc (oct,pc) = (fromIntegral oct,fromIntegral pc)  -- | Normalise 'OctPC'. --@@ -77,17 +86,20 @@     let (l',r') = (octpc_to_midi l,octpc_to_midi r)     in map midi_to_octpc [l' .. r'] --- * Midi note number+-- * Midi note number (0 - 127)  -- | Midi note number-type Midi = Int+type Midi = Word8 +midi_to_int :: Midi -> Int+midi_to_int = fromIntegral+ -- | 'OctPC' value to integral /midi/ note number. ----- > map octpc_to_midi [(0,0),(2,6),(4,9),(9,0)] == [12,42,69,120]+-- > map octpc_to_midi [(0,0),(2,6),(4,9),(6,2),(9,0)] == [12,42,69,86,120] -- > map octpc_to_midi [(0,9),(8,0)] == [21,108] octpc_to_midi :: OctPC -> Midi-octpc_to_midi = octave_pitchclass_to_midi+octpc_to_midi = fromIntegral . octave_pitchclass_to_midi  -- | Inverse of 'octpc_to_midi'. --@@ -97,6 +109,28 @@  -- * Octave & fractional pitch-class +-- | (octave,pitch-class) to fractional octave.+--   This is an odd notation, but can be useful for writing pitch data where a float is required.+--   Note this is not a linear octave, for that see 'Sound.SC3.Common.Math.oct_to_cps'.+--+-- > map octpc_to_foct [(4,0),(4,7),(5,11)] == [4.00,4.07,5.11]+octpc_to_foct :: (Integral i, Fractional r) => (i,i) -> r+octpc_to_foct (o,pc) = fromIntegral o + (fromIntegral pc / 100)++-- | Inverse of 'octpc_to_foct'.+--+-- > map foct_to_octpc [3.11,4.00,4.07,5.11] == [(3,11),(4,0),(4,7),(5,11)]+foct_to_octpc :: (Integral i, RealFrac r) => r -> (i,i)+foct_to_octpc x =+  let (p,q) = T.integral_and_fractional_parts x+  in (p,round (q * 100))++-- | 'octpc_to_midi' of 'foct_to_octpc'.+foct_to_midi :: (Integral i, RealFrac r) => r -> i+foct_to_midi = octave_pitchclass_to_midi . foct_to_octpc++-- * FMIDI+ -- | Fractional midi note number. type FMidi = Double @@ -126,6 +160,17 @@ fmidi_in_octave :: RealFrac f => Octave -> f -> f fmidi_in_octave o m = let (_,pc) = fmidi_to_foctpc m in foctpc_to_fmidi (o,pc) +-- | Print fractional midi note number as ET12 pitch with cents detune in parentheses.+--+-- > fmidi_et12_cents_pp T.pc_spell_ks 66.5 == "F♯4(+50)"+fmidi_et12_cents_pp :: Spelling PitchClass -> FMidi -> String+fmidi_et12_cents_pp sp =+    let f (m,c) =+            let d = T.num_diff_str (round c :: Int)+                d' = if null d then "" else "(" ++ d ++ ")"+            in pitch_pp (midi_to_pitch sp m) ++ d'+    in f . midi_detune_normalise . fmidi_to_midi_detune+ -- * Pitch  -- | Common music notation pitch value.@@ -139,8 +184,8 @@  -- | Simplify 'Pitch' to standard 12ET by deleting quarter tones. ----- > let p = Pitch A QuarterToneSharp 4--- > in alteration (pitch_clear_quarter_tone p) == Sharp+-- > let p = Pitch T.A T.QuarterToneSharp 4+-- > alteration (pitch_clear_quarter_tone p) == T.Sharp pitch_clear_quarter_tone :: Pitch -> Pitch pitch_clear_quarter_tone p =     let Pitch n a o = p@@ -150,7 +195,7 @@ -- -- > pitch_to_octpc (Pitch F Sharp 4) == (4,6) pitch_to_octpc :: Integral i => Pitch -> Octave_PitchClass i-pitch_to_octpc = midi_to_octave_pitchclass . pitch_to_midi+pitch_to_octpc = midi_to_octave_pitchclass . T.int_id . pitch_to_midi  -- | Is 'Pitch' 12-ET. pitch_is_12et :: Pitch -> Bool@@ -209,28 +254,18 @@  -- | Midi note number to 'Pitch'. --+-- > import Music.Theory.Pitch.Spelling.Table as T -- > let r = ["C4","E♭4","F♯4"]--- > in map (pitch_pp . midi_to_pitch pc_spell_ks) [60,63,66] == r-midi_to_pitch :: Integral i => Spelling i -> i -> Pitch+-- > map (pitch_pp . midi_to_pitch T.pc_spell_ks) [60,63,66] == r+midi_to_pitch :: (Integral i,Integral k) => Spelling k -> i -> Pitch midi_to_pitch sp = octpc_to_pitch sp . midi_to_octave_pitchclass --- | Print fractional midi note number as ET12 pitch with cents detune in parentheses.------ > fmidi_et12_cents_pp 66.5 == "F♯4(+50)"-fmidi_et12_cents_pp :: Spelling PitchClass -> Double -> String-fmidi_et12_cents_pp sp =-    let f (m,c) =-            let d = T.num_diff_str (round c :: Int)-                d' = if null d then "" else "(" ++ d ++ ")"-            in pitch_pp (midi_to_pitch sp m) ++ d'-    in f . midi_detune_normalise . fmidi_to_midi_detune- -- | Fractional midi note number to 'Pitch'. ----- > fmidi_to_pitch pc_spell_ks 69.25 == Nothing+-- > fmidi_to_pitch T.pc_spell_ks 69.25 == Nothing fmidi_to_pitch :: RealFrac n => Spelling PitchClass -> n -> Maybe Pitch fmidi_to_pitch sp m =-    let m' = round m+    let m' = T.real_round_int m         (Pitch n a o) = midi_to_pitch sp m'         q = m - fromIntegral m'     in case T.alteration_edit_quarter_tone q a of@@ -239,11 +274,11 @@  -- | Erroring variant. ----- > import Music.Theory.Pitch.Spelling--- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 65.5) == "F𝄲4"--- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 66.5) == "F𝄰4"--- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 67.5) == "A𝄭4"--- > pitch_pp (fmidi_to_pitch_err pc_spell_ks 69.5) == "B𝄭4"+-- > import Music.Theory.Pitch.Spelling as T+-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 65.5) == "F𝄲4"+-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 66.5) == "F𝄰4"+-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 67.5) == "A𝄭4"+-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 69.5) == "B𝄭4" fmidi_to_pitch_err :: (Show n,RealFrac n) => Spelling Int -> n -> Pitch fmidi_to_pitch_err sp m = fromMaybe (error (show ("fmidi_to_pitch",m))) (fmidi_to_pitch sp m) @@ -251,7 +286,6 @@ -- -- > 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,Show n) => Spelling Int -> n -> Pitch -> Pitch pitch_tranpose sp n p =@@ -264,8 +298,9 @@  -- | Octave displacement of /m2/ that is nearest /m1/. ----- > let {p = octpc_to_fmidi (2,1);q = map octpc_to_fmidi [(4,11),(4,0),(4,1)]}--- > in map (fmidi_in_octave_nearest p) q == [35,36,37]+-- > let p = octpc_to_fmidi (2,1)+-- > let q = map octpc_to_fmidi [(4,11),(4,0),(4,1)]+-- > map (fmidi_in_octave_nearest p) q == [35,36,37] fmidi_in_octave_nearest :: RealFrac n => n -> n -> n fmidi_in_octave_nearest m1 m2 =     let m2' = fmidi_in_octave (fmidi_octave m1) m2@@ -290,38 +325,44 @@ fmidi_in_octave_below :: RealFrac a => a -> a -> a fmidi_in_octave_below p q = let r = fmidi_in_octave_nearest p q in if r > p then r - 12 else r -cps_in_octave' :: Floating f => (f -> f -> f) -> f -> f -> f-cps_in_octave' f p = fmidi_to_cps . f (cps_to_fmidi p) . cps_to_fmidi+-- | CPS form of binary /fmidi/ function /f/.+lift_fmidi_binop_to_cps :: Floating f => (f -> f -> f) -> f -> f -> f+lift_fmidi_binop_to_cps f p = T.fmidi_to_cps . f (cps_to_fmidi p) . cps_to_fmidi  -- | CPS form of 'fmidi_in_octave_nearest'. -- -- > map cps_octave [440,256] == [4,4] -- > round (cps_in_octave_nearest 440 256) == 512 cps_in_octave_nearest :: (Floating f,RealFrac f) => f -> f -> f-cps_in_octave_nearest = cps_in_octave' fmidi_in_octave_nearest+cps_in_octave_nearest = lift_fmidi_binop_to_cps fmidi_in_octave_nearest --- | Raise or lower the frequency /q/ by octaves until it is in the--- octave starting at /p/.+-- | CPS form of 'fmidi_in_octave_above'. ----- > cps_in_octave_above 55.0 392.0 == 98.0-cps_in_octave_above :: (Ord a, Fractional a) => a -> a -> a-cps_in_octave_above p =-    let go q = if q > p * 2 then go (q / 2) else if q < p then go (q * 2) else q-    in go---- > cps_in_octave_above' 55.0 392.0 == 97.99999999999999-cps_in_octave_above' :: (Floating f,RealFrac f) => f -> f -> f-cps_in_octave_above' = cps_in_octave' fmidi_in_octave_above+-- > cps_in_octave_above 55.0 392.0 == 97.99999999999999+cps_in_octave_above :: (Floating f,RealFrac f) => f -> f -> f+cps_in_octave_above = lift_fmidi_binop_to_cps fmidi_in_octave_above +-- | CPS form of 'fmidi_in_octave_above'. cps_in_octave_below :: (Floating f,RealFrac f) => f -> f -> f-cps_in_octave_below = cps_in_octave' fmidi_in_octave_below+cps_in_octave_below = lift_fmidi_binop_to_cps fmidi_in_octave_below +-- | Direct implementation of 'cps_in_octave_above'.+--   Raise or lower the frequency /q/ by octaves until it is in the+--   octave starting at /p/.+--+-- > cps_in_octave_above_direct 55.0 392.0 == 98.0+cps_in_octave_above_direct :: (Ord a, Fractional a) => a -> a -> a+cps_in_octave_above_direct p q =+  let f = cps_in_octave_above_direct p+  in if q > p * 2 then f (q / 2) else if q < p then f (q * 2) else q+ -- | Set octave of /p2/ so that it nearest to /p1/. --+-- > import Music.Theory.Pitch -- > 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+-- > let r = ["B1","C2","C#2"]+-- > let f = pitch_in_octave_nearest T.cis2+-- > 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 f = pitch_to_fmidi :: Pitch -> Double@@ -349,9 +390,9 @@ -- | Rewrite 'Pitch' to not use @3/4@ tone alterations, ie. re-spell -- to @1/4@ alteration. ----- > let {p = Pitch A ThreeQuarterToneFlat 4--- >     ;q = Pitch G QuarterToneSharp 4}--- > in pitch_rewrite_threequarter_alteration p == q+-- > let p = Pitch T.A T.ThreeQuarterToneFlat 4+-- > let q = Pitch T.G T.QuarterToneSharp 4+-- > pitch_rewrite_threequarter_alteration p == q pitch_rewrite_threequarter_alteration :: Pitch -> Pitch pitch_rewrite_threequarter_alteration (Pitch n a o) =     case a of@@ -361,35 +402,15 @@  -- | Apply function to 'octave' of 'PitchClass'. ----- > pitch_edit_octave (+ 1) (Pitch A Natural 4) == Pitch A Natural 5+-- > pitch_edit_octave (+ 1) (Pitch T.A T.Natural 4) == Pitch T.A T.Natural 5 pitch_edit_octave :: (Octave -> Octave) -> Pitch -> Pitch pitch_edit_octave f (Pitch n a o) = Pitch n a (f o)  -- * Frequency (CPS) --- | /Midi/ note number to cycles per second, given frequency of ISO A4.-midi_to_cps_f0 :: (Integral i,Floating f) => f -> i -> f-midi_to_cps_f0 f0 = fmidi_to_cps_f0 f0 . fromIntegral---- | 'midi_to_cps_f0' 440.------ > map midi_to_cps [60,69] == [261.6255653005986,440.0]-midi_to_cps :: (Integral i,Floating f) => i -> f-midi_to_cps = midi_to_cps_f0 440---- | Fractional /midi/ note number to cycles per second, given frequency of ISO A4.-fmidi_to_cps_f0 :: Floating a => a -> a -> a-fmidi_to_cps_f0 f0 i = f0 * (2 ** ((i - 69) * (1 / 12)))---- | 'fmidi_to_cps_f0' 440.------ > map fmidi_to_cps [69,69.1] == [440.0,442.5488940698553]-fmidi_to_cps :: Floating a => a -> a-fmidi_to_cps = fmidi_to_cps_f0 440- -- | 'fmidi_to_cps' of 'pitch_to_fmidi', given frequency of ISO A4. pitch_to_cps_f0 :: Floating n => n -> Pitch -> n-pitch_to_cps_f0 f0 = fmidi_to_cps_f0 f0 . pitch_to_fmidi+pitch_to_cps_f0 f0 = T.fmidi_to_cps_f0 f0 . pitch_to_fmidi  -- | 'pitch_to_cps_f0' 440. pitch_to_cps :: Floating n => Pitch -> n@@ -407,8 +428,8 @@ cps_to_fmidi :: Floating a => a -> a cps_to_fmidi = cps_to_fmidi_f0 440 --- | Frequency (cycles per second) to /midi/ note number, ie. 'round'--- of 'cps_to_fmidi'.+-- | 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@@ -416,7 +437,7 @@  -- | 'midi_to_cps_f0' of 'octpc_to_midi', given frequency of ISO A4. octpc_to_cps_f0 :: (Integral i,Floating n) => n -> Octave_PitchClass i -> n-octpc_to_cps_f0 f0 = midi_to_cps_f0 f0 . octave_pitchclass_to_midi+octpc_to_cps_f0 f0 = T.midi_to_cps_f0 f0 . octave_pitchclass_to_midi  -- | 'octpc_to_cps_f0' 440. --@@ -426,16 +447,13 @@  -- | 'midi_to_octpc' of 'cps_to_midi'. cps_to_octpc :: (Floating f,RealFrac f,Integral i) => f -> Octave_PitchClass i-cps_to_octpc = midi_to_octave_pitchclass . cps_to_midi+cps_to_octpc = midi_to_octave_pitchclass . T.real_round_int . cps_to_fmidi  cps_octave :: (Floating f,RealFrac f) => f -> Octave cps_octave = fst . cps_to_octpc  -- * MIDI detune (cents) --- | Midi note number with cents detune.-type Midi_Detune' c = (Int,c)- -- | Is cents in (-50,+50]. -- -- > map cents_is_normal [-250,-75,75,250] == replicate 4 False@@ -443,45 +461,60 @@ cents_is_normal c = c > (-50) && c <= 50  -- | 'cents_is_normal' of 'snd'.-midi_detune_is_normal :: (Num c, Ord c) => Midi_Detune' c -> Bool+midi_detune_is_normal :: (Num c, Ord c) => (x,c) -> Bool midi_detune_is_normal = cents_is_normal . snd  -- | In normal form the detune is in the range (-50,+50] instead of [0,100) or wider. -- -- > map midi_detune_normalise [(60,-250),(60,-75),(60,75),(60,250)]-midi_detune_normalise :: (Ord c,Num c) => Midi_Detune' c -> Midi_Detune' c-midi_detune_normalise (m,c) =-    if c > 50-    then midi_detune_normalise (m + 1,c - 100)-    else if c > (-50)-         then (m,c)-         else midi_detune_normalise (m - 1,c + 100)+midi_detune_normalise :: (Num m,Ord c,Num c) => (m,c) -> (m,c)+midi_detune_normalise =+  let recur (m,c) =+        if c > 50+        then recur (m + 1,c - 100)+        else if c > (-50)+             then (m,c)+             else recur (m - 1,c + 100)+  in recur +-- | In normal-positive form the detune is in the range (0,+100].+--+-- > map midi_detune_normalise_positive [(60,-250),(60,-75),(60,75),(60,250)]+midi_detune_normalise_positive :: (Num m,Ord m,Ord c,Num c) => (m,c) -> (m,c)+midi_detune_normalise_positive =+  let recur (m,c) =+        if c < 0+        then recur (m - 1,c + 100)+        else if c > 100+        then recur (m + 1,c - 100)+        else (m,c)+  in recur+ -- | Inverse of 'cps_to_midi_detune', given frequency of ISO @A4@.-midi_detune_to_cps_f0 :: Real c => Double -> Midi_Detune' c -> Double-midi_detune_to_cps_f0 f0 (m,c) = fmidi_to_cps_f0 f0 (fromIntegral m + (realToFrac c / 100))+midi_detune_to_cps_f0 :: (Integral m,Real c) => Double -> (m,c) -> Double+midi_detune_to_cps_f0 f0 (m,c) = T.fmidi_to_cps_f0 f0 (fromIntegral m + (realToFrac c / 100))  -- | Inverse of 'cps_to_midi_detune'. -- -- > map midi_detune_to_cps [(69,0),(68,100)] == [440,440]-midi_detune_to_cps :: Real c => Midi_Detune' c -> Double+midi_detune_to_cps :: (Integral m,Real c) => (m,c) -> Double midi_detune_to_cps = midi_detune_to_cps_f0 440  -- | 'Midi_Detune' to fractional midi note number. -- -- > midi_detune_to_fmidi (60,50.0) == 60.50-midi_detune_to_fmidi :: Real c => Midi_Detune' c -> Double+midi_detune_to_fmidi :: (Integral m,Real c) => (m,c) -> Double midi_detune_to_fmidi (mnn,c) = fromIntegral mnn + (realToFrac c / 100)  -- | 'Midi_Detune' to 'Pitch', detune must be precisely at a notateable Pitch. ----- > let p = Pitch {note = C, alteration = QuarterToneSharp, octave = 4}--- > in midi_detune_to_pitch T.pc_spell_ks (midi_detune_nearest_24et (60,35)) == p-midi_detune_to_pitch :: Real c => Spelling Int -> Midi_Detune' c -> Pitch+-- > let p = Pitch {note = T.C, alteration = T.QuarterToneSharp, octave = 4}+-- > midi_detune_to_pitch T.pc_spell_ks (midi_detune_nearest_24et (60,35)) == p+midi_detune_to_pitch :: (Integral m,Real c) => Spelling Int -> (m,c) -> Pitch midi_detune_to_pitch sp = fmidi_to_pitch_err sp . cps_to_fmidi . midi_detune_to_cps  -- | Midi note number with real-valued cents detune.-type Midi_Detune = Midi_Detune' Double+type Midi_Detune = (Midi,Double)  -- | Fractional midi note number to 'Midi_Detune'. --@@ -506,7 +539,7 @@ -- * MIDI cents  -- | Midi note number with integral cents detune.-type Midi_Cents = Midi_Detune' Int+type Midi_Cents = (Midi,Int)  midi_detune_to_midi_cents :: Midi_Detune -> Midi_Cents midi_detune_to_midi_cents (m,c) = (m,round c)@@ -517,11 +550,47 @@ midi_cents_pp :: Midi_Cents -> String midi_cents_pp (m,c) = if cents_is_normal c then printf "%d.%02d" m c else error "midi_cents_pp" +-- * 24ET++{- | The 24ET pitch-class universe, with /sharp/ spellings, in octave '4'.++> length pc24et_univ == 24++> let r = "C C𝄲 C♯ C𝄰 D D𝄲 D♯ D𝄰 E E𝄲 F F𝄲 F♯ F𝄰 G G𝄲 G♯ G𝄰 A A𝄲 A♯ A𝄰 B B𝄲"+> unwords (map pitch_class_pp pc24et_univ) == r++-}+pc24et_univ :: [Pitch]+pc24et_univ =+    let a = [T.Natural,T.QuarterToneSharp,T.Sharp,T.ThreeQuarterToneSharp]+        f (n,k) = map (\i -> Pitch n (a !! i) 4) [0 .. k - 1]+    in concatMap f (zip T.note_seq [4,4,2,4,4,4,2])++-- | 'genericIndex' into 'pc24et_univ'.+--+-- > pitch_class_pp (pc24et_to_pitch 13) == "F𝄰"+pc24et_to_pitch :: Integral i => i -> Pitch+pc24et_to_pitch = genericIndex pc24et_univ++-- * Pitch, rational alteration.++-- | Generalised pitch, given by a generalised alteration.+data Pitch_R = Pitch_R T.Note_T T.Alteration_R Octave+               deriving (Eq,Show)++-- | Pretty printer for 'Pitch_R'.+pitch_r_pp :: Pitch_R -> String+pitch_r_pp (Pitch_R n (_,a) o) = show n ++ a ++ show o++-- | 'Pitch_R' printed without octave.+pitch_r_class_pp :: Pitch_R -> String+pitch_r_class_pp = T.dropWhileRight isDigit . pitch_r_pp+ -- * Parsers  -- | Parse possible octave from single integer. ----- > map (parse_octave 2) ["","4","x","11"]+-- > map (parse_octave 2) ["","4","x","11"] == [Just 2,Just 4,Nothing,Nothing] parse_octave :: Num a => a -> String -> Maybe a parse_octave def_o o =     case o of@@ -537,8 +606,8 @@ -- -- 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+-- > let r = [Pitch T.C T.Natural 4,Pitch T.A T.Flat 5,Pitch T.F T.DoubleSharp 6]+-- > 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 mk n a o = case T.parse_note_t True n of@@ -590,11 +659,12 @@  -- | Sequential list of /n/ pitch class names starting from /k/. ----- > unwords (pitch_class_names_12et 0 12) == "C C♯ D E♭ E F F♯ G A♭ A B♭ B"--- > pitch_class_names_12et 11 2 == ["B","C"]+-- > import Music.Theory.Pitch.Spelling.Table+-- > unwords (pitch_class_names_12et pc_spell_ks 0 12) == "C C♯ D E♭ E F F♯ G A♭ A B♭ B"+-- > pitch_class_names_12et pc_spell_ks 11 2 == ["B","C"] pitch_class_names_12et :: Integral n => Spelling n -> n -> n -> [String] pitch_class_names_12et sp k n =-    let f = pitch_class_pp . midi_to_pitch sp+    let f = pitch_class_pp . midi_to_pitch sp . T.from_integral_to_int     in map f [60 + k .. 60 + k + n - 1]  -- | Pretty printer for 'Pitch' (ISO, ASCII, see 'alteration_iso').@@ -605,6 +675,28 @@ pitch_pp_iso :: Pitch -> String pitch_pp_iso (Pitch n a o) = show n ++ T.alteration_iso a ++ show o +-- | Lilypond octave syntax.+ly_octave_tbl :: [(Octave, String)]+ly_octave_tbl =+  [(-1,",,,,")+  ,( 0,",,,")+  ,( 1,",,")+  ,( 2,",")+  ,( 3,"")+  ,( 4,"'")+  ,( 5,"''")+  ,( 6,"'''")+  ,( 7,"''''")+  ,( 8,"'''''")]++-- | Lookup 'ly_octave_tbl'.+octave_pp_ly :: Octave -> String+octave_pp_ly o = T.lookup_err o ly_octave_tbl++-- | Parse lilypond octave indicator.+octave_parse_ly :: String -> Maybe Octave+octave_parse_ly s = T.reverse_lookup s ly_octave_tbl+ -- | Pretty printer for 'Pitch' (ASCII, see 'alteration_tonh'). -- -- > pitch_pp_hly (Pitch E Flat 4) == "ees4"@@ -631,39 +723,44 @@          (T.E,T.Flat) -> "Es" ++ o'          _ -> show n ++ T.alteration_tonh a ++ o' --- * 24ET--{-  The 24ET pitch-class universe, with /sharp/ spellings, in octave '4'.+-- * Parsers -> length pc24et_univ == 24+p_octave_iso :: P.GenParser Char () Octave+p_octave_iso = fmap digitToInt P.digit -> let r = "C C𝄲 C♯ C𝄰 D D𝄲 D♯ D𝄰 E E𝄲 F F𝄲 F♯ F𝄰 G G𝄲 G♯ G𝄰 A A𝄲 A♯ A𝄰 B B𝄲"-> in unwords (map pitch_class_pp pc24et_univ) == r+p_octave_ly :: P.GenParser Char () Octave+p_octave_ly =+    fmap+    (fromMaybe (error "p_octave_ly") . octave_parse_ly)+    (P.many1 (P.oneOf ",'")) --}-pc24et_univ :: [Pitch]-pc24et_univ =-    let a = [T.Natural,T.QuarterToneSharp,T.Sharp,T.ThreeQuarterToneSharp]-        f (n,k) = map (\i -> Pitch n (a !! i) 4) [0 .. k - 1]-    in concatMap f (zip T.note_seq [4,4,2,4,4,4,2])+p_pitch_ly :: P.GenParser Char () Pitch+p_pitch_ly = do+  (n,a) <- T.p_note_alteration_ly+  o <- P.optionMaybe p_octave_ly+  return (Pitch n (fromMaybe T.Natural a) (fromMaybe 3 o)) --- | 'genericIndex' into 'pc24et_univ'.+-- | Run 'p_pitch_ly'. ----- > pitch_class_pp (pc24et_to_pitch 13) == "F𝄰"-pc24et_to_pitch :: Integral i => i -> Pitch-pc24et_to_pitch = genericIndex pc24et_univ---- * Pitch, rational alteration.---- | Generalised pitch, given by a generalised alteration.-data Pitch_R = Pitch_R T.Note_T T.Alteration_R Octave-               deriving (Eq,Show)---- | Pretty printer for 'Pitch_R'.-pitch_r_pp :: Pitch_R -> String-pitch_r_pp (Pitch_R n (_,a) o) = show n ++ a ++ show o+-- > map (pitch_pp . pitch_parse_ly_err) ["c","d'","ees,","fisis''"] == ["C3","D4","E♭2","F𝄪5"]+pitch_parse_ly_err :: String -> Pitch+pitch_parse_ly_err s =+  case P.runP p_pitch_ly () "pitch_parse_ly" s of+    Left err -> error (show err)+    Right r -> r --- | 'Pitch_R' printed without octave.-pitch_r_class_pp :: Pitch_R -> String-pitch_r_class_pp = T.dropWhileRight isDigit . pitch_r_pp+-- | Parser for hly notation.+p_pitch_hly :: P.GenParser Char () Pitch+p_pitch_hly = do+  (n,a) <- T.p_note_alteration_ly+  o <- p_octave_iso+  return (Pitch n (fromMaybe T.Natural a) o) +-- | Run 'p_pitch_hly'.+--+-- > map (pitch_pp . pitch_parse_hly) ["ees4","fih3","b6"] == ["E♭4","F𝄲3","B6"]+pitch_parse_hly :: String -> Pitch+pitch_parse_hly s =+  case P.runP p_pitch_hly () "pitch_parse_hly" s of+    Left err -> error (show err)+    Right r -> r
+ Music/Theory/Pitch/Bark.hs view
@@ -0,0 +1,69 @@+-- | Zwicker, E. (1961) "Subdivision of the audible frequency range into critical bands"+--   The Journal of the Acoustical Society of America, Volume 33, Issue 2, p. 248 (1961)+--+-- <https://ccrma.stanford.edu/courses/120-fall-2003/lecture-5.html>+module Music.Theory.Pitch.Bark where++-- * TABLES++-- | Center freqencies of Bark scale critical bands (hz).+bark_center :: Num n => [n]+bark_center =+  [50,150,250,350,450,570,700,840,1000,1170+  ,1370,1600,1850,2150,2500,2900,3400,4000,4800,5800+  ,7000,8500,10500,13500]++-- | Edge freqencies of Bark scale critical bands (hz).+bark_edge :: Num n => [n]+bark_edge =+  [0,100,200,300,400,510,630,770,920,1080,1270+  ,1480,1720,2000,2320,2700,3150,3700,4400,5300,6400+  ,7700,9500,12000,15500]++-- | Bandwidths of Bark scale critical bands (hz).+bark_bandwidth :: Num n => [n]+bark_bandwidth = let c = bark_edge in zipWith (-) (tail c) c++-- * FUNCTIONS++-- | Zwicker & Terhardt (1980)+--+-- > map (round . cps_to_bark_zwicker) bark_centre == concat [[0..7],[9..15],[15..19],[21..24]]+-- > let f = [0,100 .. 8000] in Sound.SC3.Plot.plot_p2_ln [zip f (map cps_to_bark_zwicker f)]+cps_to_bark_zwicker :: Floating a => a -> a+cps_to_bark_zwicker x = 13 * atan (0.00076 * x) + 3.5 * atan ((x / 7500) ** 2)++-- | Traunmüller, Hartmut.+--   "Analytical Expressions for the Tonotopic Sensory Scale."+--   Journal of the Acoustical Society of America. Vol. 88, Issue 1, 1990, pp. 97-100.+--+-- > r = concat [[0,1],[3,4],[4],[6..9],[9,10],[12],[12..17],[19,20],[20..23]]+-- > map (round . cps_to_bark_traunmuller) bark_centre == r+-- > let f = [0,100 .. 8000] in Sound.SC3.Plot.plot_p2_ln [zip f (map cps_to_bark_traunmuller f)]+cps_to_bark_traunmuller :: (Fractional n,Ord n) => n -> n+cps_to_bark_traunmuller x =+  let y = ((26.81 * x) / (1960 + x)) - 0.53+  in if y < 2 then y + 0.15 * (2 - y) else if y > 20.1 then y + 0.22 * (y - 20.1) else y++-- | Traunmüller (1990)+--+-- > Sound.SC3.Plot.plot_p2_ln [zip (map bark_to_cps_traunmuller [0..23]) [0..23]]+bark_to_cps_traunmuller :: (Fractional n,Ord n) => n -> n+bark_to_cps_traunmuller y =+  let f x = 1960 * ((x + 0.53) / (26.28 - x))+  in if y < 2 then f ((y - 0.3) / 0.85) else if y > 20.1 then f ((y + 4.422) / 1.22) else f y++-- | Wang, Sekey & Gersho (1992)+--+-- > map (round . cps_to_bark_wsg) bark_centre == concat [[0..9],[9..21],[23]]+-- > let f = [0,100 .. 8000] in Sound.SC3.Plot.plot_p2_ln [zip f (map cps_to_bark_wsg f)]+cps_to_bark_wsg :: Floating a => a -> a+cps_to_bark_wsg x = 6 * asinh (x / 600)++-- | Wang, Sekey & Gersho (1992)+--+-- > r = [100,204,313,430,560,705,870,1059,1278,1532,1828,2176,2584,3065,3630,4297,5083,6011,7106,8399]+-- > map (round . bark_to_cps_wsg) [1 .. 20] == r+-- > Sound.SC3.Plot.plot_p2_ln [zip (map bark_to_cps_wsg [0..23]) [0..23]]+bark_to_cps_wsg :: Floating a => a -> a+bark_to_cps_wsg x = 600 * sinh (x / 6)
Music/Theory/Pitch/Chord.hs view
@@ -3,7 +3,8 @@ import Data.List {- base -} import Data.Maybe {- base -} -import qualified Text.ParserCombinators.Parsec as P {- parsec -}+import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as P {- parsec -}  import qualified Music.Theory.Key as T {- hmt -} import qualified Music.Theory.List as T {- hmt -}@@ -94,22 +95,10 @@ m_error :: String -> Maybe a -> a m_error txt = fromMaybe (error txt) -p_note_t :: P T.Note_T-p_note_t =-    fmap-    (m_error "p_note_t" . T.parse_note_t False)-    (P.oneOf "ABCDEFG")--p_alteration_t_iso :: P T.Alteration_T-p_alteration_t_iso =-    fmap-    (m_error "p_alteration_t_iso" . T.symbol_to_alteration_iso)-    (P.oneOf "b#x")- p_pc :: P PC p_pc = do-  n <- p_note_t-  a <- P.optionMaybe p_alteration_t_iso+  n <- T.p_note_t+  a <- P.optionMaybe T.p_alteration_t_iso   return (n,fromMaybe T.Natural a)  p_mode_m :: P T.Mode_T@@ -149,6 +138,8 @@                _ -> error ("trailing type not sus2 or sus4: " ++ show ty')   return (CH pc ty'' ex b) +-- | Parse chord.+-- -- > let ch = words "CmM7 C#o EbM7 Fo7 Gx/D C/E GØ/F Bbsus4/C E7sus2" -- > let c = map parse_chord ch -- > map chord_pp c == ch
Music/Theory/Pitch/Note.hs view
@@ -4,6 +4,9 @@ import Data.Char {- base -} import Data.Maybe {- base -} +import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as P {- parsec -}+ import qualified Music.Theory.List as T {- hmt -}  -- * Note_T@@ -20,6 +23,10 @@ note_pp :: Note_T -> Char note_pp = head . show +-- | Note name in lilypond syntax (ie. lower case).+note_pp_ly :: Note_T -> String+note_pp_ly = map toLower . show+ -- | Table of 'Note_T' and corresponding pitch-classes. note_pc_tbl :: Num i => [(Note_T,i)] note_pc_tbl = zip [C .. B] [0,2,4,5,7,9,11]@@ -28,7 +35,7 @@ -- -- > map note_to_pc [C,E,G] == [0,4,7] note_to_pc :: Num i => Note_T -> i-note_to_pc n = fromMaybe (error "note_to_pc") (lookup n note_pc_tbl)+note_to_pc n = T.lookup_err_msg "note_to_pc" n note_pc_tbl  -- | Inverse of 'note_to_pc'. --@@ -182,6 +189,7 @@       ThreeQuarterToneSharp -> Sharp       _ -> x +-- | Table of Unicode characters for alterations. alteration_symbol_tbl :: [(Alteration_T,Char)] alteration_symbol_tbl =     [(DoubleFlat,'𝄫')@@ -219,6 +227,7 @@       'x' -> Just DoubleSharp       _ -> symbol_to_alteration c +-- | ISO alteration table, strings not characters because of double flat. alteration_iso_tbl :: [(Alteration_T,String)] alteration_iso_tbl =     [(DoubleFlat,"bb")@@ -242,31 +251,43 @@     in fromMaybe qt . alteration_iso_m  -- | The /Tonhöhe/ ASCII spellings for alterations.+alteration_tonh_tbl :: [(Alteration_T, String)]+alteration_tonh_tbl =+  [(DoubleFlat,"eses")+  ,(ThreeQuarterToneFlat,"eseh")+  ,(Flat,"es")+  ,(QuarterToneFlat,"eh")+  ,(Natural,"")+  ,(QuarterToneSharp,"ih")+  ,(Sharp,"is")+  ,(ThreeQuarterToneSharp,"isih")+  ,(DoubleSharp,"isis")]++-- | 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"+alteration_tonh a = T.lookup_err a alteration_tonh_tbl +-- | Inverse of 'alteration_tonh'.+--+-- > mapMaybe tonh_to_alteration ["es","eh","","ih","is"] == [Flat .. Sharp]+tonh_to_alteration :: String -> Maybe Alteration_T+tonh_to_alteration s = T.reverse_lookup s alteration_tonh_tbl+ -- * 12-ET +-- | Note and alteration to pitch-class, or not. note_alteration_to_pc :: (Note_T,Alteration_T) -> Maybe Int note_alteration_to_pc (n,a) =     let n_pc = note_to_pc n     in fmap ((`mod` 12) . (+ n_pc)) (alteration_to_diff a) +-- | Error variant.+-- -- > map note_alteration_to_pc_err [(A,DoubleSharp),(B,Sharp),(C,Flat),(C,DoubleFlat)] note_alteration_to_pc_err :: (Note_T, Alteration_T) -> Int note_alteration_to_pc_err = fromMaybe (error "note_alteration_to_pc") . note_alteration_to_pc@@ -294,6 +315,42 @@ -- | Transform 'Alteration_T' to 'Alteration_R'. -- -- > let r = [(-1,"♭"),(0,"♮"),(1,"♯")]--- > in map alteration_t' [Flat,Natural,Sharp] == r+-- > map alteration_r [Flat,Natural,Sharp] == r alteration_r :: Alteration_T -> Alteration_R alteration_r a = (alteration_to_fdiff a,[alteration_symbol a])++-- * Parsers++-- > map (P.runP p_note_t () "" . return) "ABCDEFG"+p_note_t :: P.GenParser Char () Note_T+p_note_t =+    fmap+    (fromMaybe (error "p_note_t") . parse_note_t False)+    (P.oneOf "ABCDEFG")++p_note_t_lc :: P.GenParser Char () Note_T+p_note_t_lc =+    fmap+    (fromMaybe (error "p_note_t_lc") . parse_note_t False . toUpper)+    (P.oneOf "abcdefg")++-- > map (P.runP p_alteration_t_iso () "" . return) "b#x"+p_alteration_t_iso :: P.GenParser Char () Alteration_T+p_alteration_t_iso =+    fmap+    (fromMaybe (error "p_alteration_t_iso") . symbol_to_alteration_iso)+    (P.oneOf "b#x")++-- > map (P.runP p_alteration_t_tonh () "") ["eses","es","is","isis"]+p_alteration_t_tonh :: P.GenParser Char () Alteration_T+p_alteration_t_tonh =+    fmap+    (fromMaybe (error "p_alteration_t_tonh") . tonh_to_alteration)+    (P.many1 (P.oneOf "ehis"))++-- > map (P.runP p_note_alteration_ly () "") ["c","ees","fis","aeses"]+p_note_alteration_ly :: P.GenParser Char () (Note_T,Maybe Alteration_T)+p_note_alteration_ly = do+  n <- p_note_t_lc+  a <- P.optionMaybe p_alteration_t_tonh+  return (n,a)
Music/Theory/Pitch/Spelling.hs view
@@ -15,5 +15,5 @@         Just r -> r         Nothing -> map T.octpc_to_pitch_ks o -spell_midi_set :: [T.Midi] -> [T.Pitch]-spell_midi_set = spell_octpc_set . map T.midi_to_octpc+spell_midi_set :: Integral i => [i] -> [T.Pitch]+spell_midi_set = spell_octpc_set . map T.midi_to_octave_pitchclass
Music/Theory/Pitch/Spelling/Cluster.hs view
@@ -150,7 +150,7 @@ -- in octave @4@. -- -- > let f = (fmap (map T.pitch_pp) . spell_cluster_c4)--- > in map f [[11,0],[11]] == [Just ["B3","C4"],Just ["B4"]]+-- > map f [[11,0],[11],[0,11]] == [Just ["B3","C4"],Just ["B4"],Nothing] -- -- > fmap (map T.pitch_pp) (spell_cluster_c4 [10,11]) == Just ["A♯4","B4"] spell_cluster_c4 :: [T.PitchClass] -> Maybe [T.Pitch]@@ -181,6 +181,8 @@ -- >     ;g = map T.pitch_pp .fromJust . spell_cluster_f f -- >     ;r = [["B3","C4"],["B3"],["C4"],["A♯4","B4"]]} -- > in map g [[11,0],[11],[0],[10,11]] == r+--+-- > map (spell_cluster_f (const 4)) [[0,11],[11,0],[6,7],[7,6]] spell_cluster_f :: (T.PitchClass -> T.Octave) -> [T.PitchClass] -> Maybe [T.Pitch] spell_cluster_f o_f p =     let fn r = case r of
Music/Theory/Pitch/Spelling/Table.hs view
@@ -3,7 +3,7 @@  import Data.Maybe {- base -} -import Music.Theory.Pitch {- hmt -}+import qualified Music.Theory.Pitch as T {- hmt -} import Music.Theory.Pitch.Note {- hmt -}  type Spelling_Table i = [(i,(Note_T,Alteration_T))]@@ -48,54 +48,54 @@       ,(8,(A,Flat)) -- 3♭/3♯       ,(10,(B,Flat))] -- 1♭ -pc_spell_tbl :: Integral i => Spelling_Table i -> Spelling i+pc_spell_tbl :: Integral i => Spelling_Table i -> T.Spelling i pc_spell_tbl tbl = fromMaybe (error "pc_spell_tbl") . flip lookup tbl  -- | Spell using indicated table prepended to and 'pc_spell_natural_tbl' and 'pc_spell_ks_tbl'-pc_spell_tbl_ks :: Integral i => Spelling_Table i -> Spelling i+pc_spell_tbl_ks :: Integral i => Spelling_Table i -> T.Spelling i pc_spell_tbl_ks tbl = pc_spell_tbl (tbl ++ pc_spell_natural_tbl ++ pc_spell_ks_tbl)  -- | Spelling for natural (♮) notes only. -- -- > map pc_spell_natural_m [0,1] == [Just (C,Natural),Nothing]-pc_spell_natural_m :: Integral i => Spelling_M i+pc_spell_natural_m :: Integral i => T.Spelling_M i pc_spell_natural_m = flip lookup pc_spell_natural_tbl  -- | Erroring variant of 'pc_spell_natural_m'. -- -- > map pc_spell_natural [0,5,7] == [(C,Natural),(F,Natural),(G,Natural)]-pc_spell_natural :: Integral i => Spelling i+pc_spell_natural :: Integral i => T.Spelling i pc_spell_natural = pc_spell_tbl pc_spell_natural_tbl  -- | Lookup 'pc_spell_ks_tbl'. -- -- > map pc_spell_ks [6,8] == [(F,Sharp),(A,Flat)]-pc_spell_ks :: Integral i => Spelling i+pc_spell_ks :: Integral i => T.Spelling i pc_spell_ks = pc_spell_tbl_ks []  -- | Use always sharp (♯) spelling. -- -- > map pc_spell_sharp [6,8] == [(F,Sharp),(G,Sharp)] -- > Data.List.nub (map (snd . pc_spell_sharp) [1,3,6,8,10]) == [Sharp]-pc_spell_sharp :: Integral i => Spelling i+pc_spell_sharp :: Integral i => T.Spelling i pc_spell_sharp = pc_spell_tbl (pc_spell_sharp_tbl ++ pc_spell_natural_tbl)  -- | Use always flat (♭) spelling. -- -- >  map pc_spell_flat [6,8] == [(G,Flat),(A,Flat)] -- >  Data.List.nub (map (snd . pc_spell_flat) [1,3,6,8,10]) == [Flat]-pc_spell_flat :: Integral i => Spelling i+pc_spell_flat :: Integral i => T.Spelling i pc_spell_flat = pc_spell_tbl (pc_spell_flat_tbl ++ pc_spell_natural_tbl) -octpc_to_pitch_ks :: Integral i => Octave_PitchClass i -> Pitch-octpc_to_pitch_ks = octpc_to_pitch pc_spell_ks+octpc_to_pitch_ks :: Integral i => T.Octave_PitchClass i -> T.Pitch+octpc_to_pitch_ks = T.octpc_to_pitch pc_spell_ks  -- | 'midi_to_pitch' 'T.pc_spell_ks'.-midi_to_pitch_ks :: Integral i => i -> Pitch-midi_to_pitch_ks = midi_to_pitch pc_spell_ks+midi_to_pitch_ks :: Integral i => i -> T.Pitch+midi_to_pitch_ks = T.midi_to_pitch (pc_spell_ks :: T.Spelling Int) -fmidi_to_pitch_ks :: (Show n,RealFrac n) => n -> Pitch-fmidi_to_pitch_ks = fmidi_to_pitch_err pc_spell_ks+fmidi_to_pitch_ks :: (Show n,RealFrac n) => n -> T.Pitch+fmidi_to_pitch_ks = T.fmidi_to_pitch_err pc_spell_ks -midi_detune_to_pitch_ks :: Real c => Midi_Detune' c -> Pitch-midi_detune_to_pitch_ks = midi_detune_to_pitch pc_spell_ks+midi_detune_to_pitch_ks :: (Integral m,Real c) => (m,c) -> T.Pitch+midi_detune_to_pitch_ks = T.midi_detune_to_pitch pc_spell_ks
Music/Theory/Random/I_Ching.hs view
@@ -1,14 +1,18 @@-{-# Language BinaryLiterals #-}-+-- | YIJING / I-CHING module Music.Theory.Random.I_Ching where  import Control.Monad {- base -} import Data.Maybe {- base -}+import Data.Int {- base -} import System.Random {- random -}  import qualified Music.Theory.Bits as T {- hmt -}+import qualified Music.Theory.Read as T {- hmt -} import qualified Music.Theory.Tuple as T {- hmt -}+import qualified Music.Theory.Unicode as T {- hmt -} +-- * LINE+ -- | Line, indicated as sum. data Line = L6 | L7 | L8 | L9 deriving (Eq,Show) @@ -19,17 +23,19 @@ -} type Line_Stat = (Line,(Rational,Rational,String,String,String)) +-- | I-CHING chart as sequence of 4 'Line_Stat'. i_ching_chart :: [Line_Stat] i_ching_chart =     [(L6,(1/16,2/16,"old yin","yin changing into yang","---x---"))+    ,(L7,(5/16,6/16,"young yang","yang unchanging","-------"))     ,(L8,(7/16,6/16,"young yin","yin unchanging","--- ---"))-    ,(L9,(3/16,2/16,"old yang","yang changing into yin","---o---"))-    ,(L7,(5/16,6/16,"young yang","yang unchanging","-------"))]+    ,(L9,(3/16,2/16,"old yang","yang changing into yin","---o---"))]  -- | Lines L6 and L7 are unbroken (since L6 is becoming L7). line_unbroken :: Line -> Bool line_unbroken n = n `elem` [L6,L7] +-- | If /b/ then L7 else L8. line_from_bit :: Bool -> Line line_from_bit b = if b then L7 else L8 @@ -49,16 +55,11 @@       L9 -> Just L8       _ -> Nothing -type Hexagram = [Line]---- | Hexagrams are drawn upwards.-hexagram_pp :: Hexagram -> String-hexagram_pp = unlines . reverse . map line_ascii_pp- {- | Sequence of sum values assigned to ascending four bit numbers.+     Sequence is in ascending probablity, ie: 1×6,3×9,5×7,7×8. -> import  Music.Theory.Bits {- hmt -}-> zip (map (gen_bitseq_pp 4) [0::Int .. 15]) (map line_ascii_pp_err four_coin_sequence)+> import Music.Theory.Bits {- hmt -}+> zip (map (gen_bitseq_pp 4) [0::Int .. 15]) (map line_ascii_pp four_coin_sequence)  -} four_coin_sequence :: [Line]@@ -68,6 +69,15 @@     ,L7,L8,L8,L8     ,L8,L8,L8,L8] +-- * HEXAGRAM++-- | Sequence of 6 'Line'.+type Hexagram = [Line]++-- | Hexagrams are drawn upwards.+hexagram_pp :: Hexagram -> String+hexagram_pp = unlines . reverse . map line_ascii_pp+ -- | Generate hexagram (ie. sequence of six lines given by sum) using 'four_coin_sequence'. -- -- > four_coin_gen_hexagram >>= putStrLn . hexagram_pp@@ -88,7 +98,7 @@     let f n = fromMaybe n (line_complement n)     in if hexagram_has_complement h then Just (map f h) else Nothing --- | Names of hexagrams, in King Wen order.+-- | Names of hexagrams, in King Wen order (see also data/csv/combinatorics/yijing.csv) -- -- > length hexagram_names == 64 hexagram_names :: [(String,String)]@@ -163,30 +173,47 @@ -- > import Data.List.Split {- split -} -- > mapM_ putStrLn (chunksOf 8 hexagram_unicode_sequence) hexagram_unicode_sequence :: [Char]-hexagram_unicode_sequence = map toEnum [0x4DC0 .. 0x4DFF]+hexagram_unicode_sequence = map (toEnum . fst) T.yijing_tbl -hexagram_to_binary :: Hexagram -> Int+-- | Binary form of 'Hexagram'.+hexagram_to_binary :: Hexagram -> Int8 hexagram_to_binary = T.pack_bitseq . map line_unbroken --- > let h = hexagram_from_binary 0b100010--- > putStrLn (hexagram_pp h)--- > gen_bitseq_pp 6 (hexagram_to_binary h) == "100010"-hexagram_from_binary :: Int -> Hexagram+-- | Show binary form.+hexagram_to_binary_str :: Hexagram -> String+hexagram_to_binary_str = T.gen_bitseq_pp 6 . hexagram_to_binary++-- | Inverse of 'hexagram_to_binary'.+hexagram_from_binary :: Int8 -> Hexagram hexagram_from_binary = map line_from_bit . T.gen_bitseq 6 +-- | Read binary form.+--+-- > let h = hexagram_from_binary_str "100010"+-- > putStrLn (hexagram_pp h)+-- > hexagram_to_binary_str h == "100010"+hexagram_from_binary_str :: String -> Hexagram+hexagram_from_binary_str = hexagram_from_binary . T.read_bin_err++-- * TRIGRAM++-- | Unicode sequence of trigrams (unicode order).+-- -- > import Data.List {- base -} -- > putStrLn (intersperse ' ' trigram_unicode_sequence) trigram_unicode_sequence :: [Char]-trigram_unicode_sequence = map toEnum [0x2630 .. 0x2637]+trigram_unicode_sequence = map (toEnum . fst) T.bagua_tbl --- > map p8_third trigram_chart == [7,6,5,4,3,2,1,0]-trigram_chart :: Num i => [(i, Char, i, Char, String, Char, String, Char)]+-- | (INDEX,UNICODE,BIT-SEQUENCE,NAME,NAME-TRANSLITERATION,NATURE-IMAGE,DIRECTION,ANIMAL)+--+-- > map (T.read_bin_err . T.p8_third) trigram_chart == [7,6,5,4,3,2,1,0]+trigram_chart :: [(Int, Char, String, Char, String, Char, String, Char)] trigram_chart =-    [(1,'☰',0b111,'乾',"qián",'天',"NW",'馬')-    ,(2,'☱',0b110,'兌',"duì",'澤',"W",'羊')-    ,(3,'☲',0b101,'離',"lí",'火',"S",'雉')-    ,(4,'☳',0b100,'震',"zhèn",'雷',"E",'龍')-    ,(5,'☴',0b011,'巽',"xùn",'風',"SE",'雞')-    ,(6,'☵',0b010,'坎',"kǎn",'水',"N",'豕')-    ,(7,'☶',0b001,'艮',"gèn",'山',"NE",'狗')-    ,(8,'☷',0b000,'坤',"kūn",'地',"SW",'牛')]+    [(1,'☰',"111",'乾',"qián",'天',"NW",'馬')+    ,(2,'☱',"110",'兌',"duì",'澤',"W",'羊')+    ,(3,'☲',"101",'離',"lí",'火',"S",'雉')+    ,(4,'☳',"100",'震',"zhèn",'雷',"E",'龍')+    ,(5,'☴',"011",'巽',"xùn",'風',"SE",'雞')+    ,(6,'☵',"010",'坎',"kǎn",'水',"N",'豕')+    ,(7,'☶',"001",'艮',"gèn",'山',"NE",'狗')+    ,(8,'☷',"000",'坤',"kūn",'地',"SW",'牛')]
+ Music/Theory/Random/Jones_1981.hs view
@@ -0,0 +1,60 @@+-- | Kevin Jones. "Compositional Applications of Stochastic Processes".+--   Computer Music Journal, 5(2):45-58, 1981.+module Music.Theory.Random.Jones_1981 where++import Data.List {- base -}+import Data.Maybe {- base -}+import System.Random {- random -}++-- * Stochastic Finite State Grammars++data G a = T a | P (G a) (G a) deriving (Eq,Show)++type Rule k a = k -> a -> Maybe (a,a)+type Probablities k r = (r,[(k,r)])+type SFSG k a r = (Rule k a,Probablities k r)++-- > p_verify (1/2,[('a',1/4),('b',1/4)]) == True+p_verify :: (Eq a,Num a) => Probablities k a -> Bool+p_verify (t,k) = sum (t : map snd k) == 1++p_select :: (Ord a, Num a) => Probablities k a -> a -> Maybe (Maybe k)+p_select (t,k) =+  let windex w n = findIndex (n <) (scanl1 (+) w)+      (kk,kn) = unzip k+      f i = case i of+              0 -> Nothing+              _ -> Just (kk !! (i - 1))+  in fmap f . windex (t : kn)++-- > let p = (1/2,[('a',1/4),('b',1/4)])+-- > map (p_select_err p) [0,0.5,0.75] == [Nothing,Just 'a',Just 'b']+p_select_err :: (Ord a, Num a) => Probablities k a -> a -> Maybe k+p_select_err p = fromMaybe (error "p_select") . p_select p++g_collect :: G a -> [a]+g_collect g =+  case g of+    T e -> [e]+    P p q -> g_collect p ++ g_collect q++unfold :: (RandomGen g,Random r,Ord r,Num r) => SFSG k a r -> a -> g -> (G a,g)+unfold (r,p) st g =+  let (n,g') = randomR (0,1) g+  in case p_select_err p n of+       Nothing -> (T st,g')+       Just k ->+         case r k st of+           Nothing -> (T st,g')+           Just (i,j) ->+             let (i',g'') = unfold (r,p) i g'+                 (j',g''') = unfold (r,p) j g''+             in (P i' j',g''')++sfsg_chain :: (RandomGen g,Random r,Ord r,Num r) => SFSG k a r -> a -> g -> [G a]+sfsg_chain gr st g =+  let (x,g') = unfold gr st g+  in x : sfsg_chain gr st g'++sfsg_chain_n :: (RandomGen g,Random r,Ord r,Num r) => Int -> SFSG k a r -> a -> g -> [G a]+sfsg_chain_n n gr st = take n . sfsg_chain gr st
Music/Theory/Read.hs view
@@ -5,6 +5,7 @@ import Data.List {- base -} import Data.Maybe {- base -} import Data.Ratio {- base -}+import Data.Word {- base -} import Numeric {- base -}  -- | Transform 'ReadS' function into precise 'Read' function.@@ -24,7 +25,8 @@     reads_to_read_precise f  -- | 'reads_to_read_precise' of 'reads'.--- space character.+--+-- > read_maybe "1.0" :: Maybe Int read_maybe :: Read a => String -> Maybe a read_maybe = reads_to_read_precise reads @@ -34,9 +36,13 @@ read_def :: Read a => a -> String -> a read_def x s = maybe x id (read_maybe s) --- | Variant of 'read_maybe' that errors on 'Nothing'.+-- | Variant of 'read_maybe' that errors on 'Nothing', printing message.+read_err_msg :: Read a => String -> String -> a+read_err_msg msg s = maybe (error ("read_err: " ++ msg ++ ": " ++ s)) id (read_maybe s)++-- | Default message. read_err :: Read a => String -> a-read_err s = maybe (error ("read_err: " ++ s)) id (read_maybe s)+read_err = read_err_msg "read_maybe failed"  -- | Variant of 'reads' requiring exact match, no trailing white space. --@@ -110,7 +116,7 @@  -- | Type specialised 'read_maybe'. ----- > map read_maybe_int ["2","2:","2\n"] == [Just 2,Nothing,Just 2]+-- > map read_maybe_int ["2","2:","2\n","x"] == [Just 2,Nothing,Just 2,Nothing] read_maybe_int :: String -> Maybe Int read_maybe_int = read_maybe @@ -140,8 +146,49 @@  -- * Numeric variants +-- | Read binary integer.+--+-- > mapMaybe read_bin (words "000 001 010 011 100 101 110 111") == [0 .. 7]+read_bin :: Integral a => String -> Maybe a+read_bin = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt++-- | Erroring variant.+read_bin_err :: Integral a => String -> a+read_bin_err = fromMaybe (error "read_bin") . read_bin++-- * HEX+ -- | Error variant of 'readHex'. -- -- > read_hex_err "F0B0" == 61616 read_hex_err :: (Eq n,Num n) => String -> n read_hex_err = reads_to_read_precise_err "readHex" readHex++-- | Read hex value from string of at most /k/ places.+read_hex_sz :: (Eq n, Num n) => Int -> String -> n+read_hex_sz k str =+  if length str > k+  then error "read_hex_sz? = > K"+  else case readHex str of+         [(r,[])] -> r+         _ -> error "read_hex_sz? = PARSE"++-- | Read hexadecimal representation of 32-bit unsigned word.+--+-- > map read_hex_word32 ["00000000","12345678","FFFFFFFF"] == [minBound,305419896,maxBound]+read_hex_word32 :: String -> Word32+read_hex_word32 = read_hex_sz 8++-- * RATIONAL++-- | Parser for 'rational_pp'.+--+-- > map rational_parse ["1","3/2","5/4","2"] == [1,3/2,5/4,2]+-- > rational_parse "" == undefined+rational_parse :: (Read t,Integral t) => String -> Ratio t+rational_parse s =+  case break (== '/') s of+    ([],_) -> error "rational_parse"+    (n,[]) -> read n % 1+    (n,_:d) -> read n % read d+
Music/Theory/Set/List.hs view
@@ -30,7 +30,7 @@ -- -- > powerset' [1,2,3] == [[1],[2],[3],[1,2],[1,3],[2,3],[1,2,3]] powerset' :: Ord a => [a] -> [[a]]-powerset' = tail . T.sort_by_two_stage length id . powerset+powerset' = tail . T.sort_by_two_stage_on length id . powerset  -- | Two element subsets. --
Music/Theory/Show.hs view
@@ -1,2 +1,130 @@ -- | Show functions. module Music.Theory.Show where++import Data.Char {- base -}+import Data.List {- base -}+import Data.Ratio {- base -}+import Numeric {- base -}++import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Math.Convert as T {- hmt -}++-- * DIFF++-- | Show positive and negative values always with sign, maybe show zero, maybe right justify.+--+-- > map (num_diff_str_opt (True,2)) [-2,-1,0,1,2] == ["-2","-1"," 0","+1","+2"]+num_diff_str_opt :: (Ord a, Num a, Show a) => (Bool,Int) -> a -> String+num_diff_str_opt (wr_0,k) n =+  let r = case compare n 0 of+            LT -> '-' : show (abs n)+            EQ -> if wr_0 then "0" else ""+            GT -> '+' : show n+  in if k > 0 then T.pad_left ' ' k r else r++-- | 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 = num_diff_str_opt (False,0)++-- * RATIONAL++-- | Pretty printer for 'Rational' using @/@ and eliding denominators of @1@.+--+-- > map rational_pp [1,3/2,5/4,2] == ["1","3/2","5/4","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, if /nil/ is True elide unit denominator.+--+-- > map (ratio_pp_opt True) [1,3/2,2] == ["1","3:2","2"]+ratio_pp_opt :: Bool -> Rational -> String+ratio_pp_opt nil r =+  let f :: (Integer,Integer) -> String+      f (n,d) = concat [show n,":",show d]+  in case T.rational_nd r of+       (n,1) -> if nil then show n else f (n,1)+       x -> f x++-- | 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 = ratio_pp_opt False++-- | Show rational to /n/ decimal places.+--+-- > let r = approxRational pi 1e-100+-- > r == 884279719003555 / 281474976710656+-- > show_rational_decimal 12 r == "3.141592653590"+-- > show_rational_decimal 3 (-100) == "-100.000"+show_rational_decimal :: Int -> Rational -> String+show_rational_decimal n = double_pp n . fromRational++-- * REAL++-- | Show /r/ as float to /k/ places.+--+-- > real_pp 4 (1/3 :: Rational) == "0.3333"+-- > map (real_pp 4) [1,1.1,1.12,1.123,1.1234,1/0,sqrt (-1)]+real_pp :: Real t => Int -> t -> String+real_pp k = realfloat_pp k . T.real_to_double++-- | Variant that writes `∞` for Infinity.+--+-- > putStrLn $ unwords $ map (real_pp_unicode 4) [1/0,-1/0]+real_pp_unicode :: Real t => Int -> t -> [Char]+real_pp_unicode k r =+  case real_pp k r of+    "Infinity" -> "∞"+    "-Infinity" -> "-∞"+    s -> s++-- | Prints /n/ as integral or to at most /k/ decimal places. Does not print -0.+--+-- > real_pp_trunc 4 (1/3 :: Rational) == "0.3333"+-- > map (real_pp_trunc 4) [1,1.1,1.12,1.123,1.1234] == ["1","1.1","1.12","1.123","1.1234"]+-- > map (real_pp_trunc 4) [1.00009,1.00001] == ["1.0001","1"]+-- > map (real_pp_trunc 2) [59.999,60.001,-0.00,-0.001]+real_pp_trunc :: Real t => Int -> t -> String+real_pp_trunc k n =+  case break (== '.') (real_pp k n) of+    (i,[]) -> i+    (i,j) -> case dropWhileEnd (== '0') j of+               "." -> if i == "-0" then "0" else i+               z -> i ++ z++-- | 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"]+-- > map (realfloat_pp 4) [1,1.1,1.12,1.123,1.1234,1/0,sqrt (-1)]+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 4 0+double_pp :: Int -> Double -> String+double_pp = realfloat_pp++-- * BIN++-- | Read binary integer.+--+-- > unwords (map (show_bin Nothing) [0 .. 7]) == "0 1 10 11 100 101 110 111"+-- > unwords (map (show_bin (Just 3)) [0 .. 7]) == "000 001 010 011 100 101 110 111"+show_bin :: (Integral i,Show i) => Maybe Int -> i -> String+show_bin k n = (maybe id (\x -> T.pad_left '0' x) k) (showIntAtBase 2 intToDigit n "")
Music/Theory/String.hs view
@@ -3,6 +3,12 @@  import Data.Char {- base -} +-- | Case-insensitive '=='.+--+-- > map (str_eq_ci "ci") (words "CI ci Ci cI")+str_eq_ci :: String -> String -> Bool+str_eq_ci x y = map toUpper x == map toUpper y+ -- | Remove @\r@. filter_cr :: String -> String filter_cr = filter (not . (==) '\r')@@ -13,3 +19,22 @@ delete_trailing_whitespace :: String -> String delete_trailing_whitespace = reverse . dropWhile isSpace . reverse +{- | Variant of 'unwords' that does not write spaces for NIL elements.++> unwords_nil [] == ""+> unwords_nil ["a"] == "a"+> unwords_nil ["a",""] == "a"+> unwords_nil ["a","b"] == "a b"+> unwords_nil ["a","","b"] == "a b"+> unwords_nil ["a","","","b"] == "a b"+> unwords_nil ["a","b",""] == "a b"+> unwords_nil ["a","b","",""] == "a b"+> unwords_nil ["","a","b"] == "a b"+> unwords_nil ["","","a","b"] == "a b"+-}+unwords_nil :: [String] -> String+unwords_nil = unwords . filter (not . null)++-- | Variant of 'unlines' that does not write empty lines for NIL elements.+unlines_nil :: [String] -> String+unlines_nil = unlines . filter (not . null)
Music/Theory/Time/Bel1990/R.hs view
@@ -20,10 +20,12 @@ import Data.Function {- base -} import Data.List {- base -} import Data.Ratio {- base -}-import qualified Text.ParserCombinators.Parsec as P {- parsec -} +import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as P {- parsec -}+ import qualified Music.Theory.List as T-import qualified Music.Theory.Math as T+import qualified Music.Theory.Show as T  -- * Bel
Music/Theory/Time/Notation.hs view
@@ -1,23 +1,304 @@+-- | Time and duration notations. module Music.Theory.Time.Notation where  import Data.List.Split {- split -}+import qualified Data.Time as T {- time -} import Text.Printf {- base -} --- | Fractional seconds.-type FSEC = Double+import Music.Theory.Function {- hmt -} +-- * Integral types++-- | Week, one-indexed, ie. 1-52+type WEEK = Int++-- | Week, one-indexed, ie. 1-31+type DAY = Int++-- | Hour, zero-indexed, ie. 0-23+type HOUR = Int++-- | Minute, zero-indexed, ie. 0-59+type MIN = Int++-- | Second, zero-indexed, ie. 0-59+type SEC = Int++-- | Centi-seconds, one-indexed, ie. 0-99+type CSEC = Int -- (0-99)++-- * Composite types+ -- | Minutes, seconds as @(min,sec)@ type MinSec n = (n,n)  -- | Type specialised.-type MINSEC = (Int,Int)+type MINSEC = (MIN,SEC)  -- | Minutes, seconds, centi-seconds as @(min,sec,csec)@ type MinCsec n = (n,n,n)  -- | Type specialised.-type MINCSEC = (Int,Int,Int)+type MINCSEC = (MIN,SEC,CSEC) +-- | (Hours,Minutes,Seconds)+type HMS = (HOUR,MIN,SEC)++-- | (Days,Hours,Minutes,Seconds)+type DHMS = (DAY,HOUR,MIN,SEC)++-- * Fractional types++-- | Fractional days.+type FDAY = Double++-- | Fractional hour, ie. 1.50 is one and a half hours, ie. 1 hour and 30 minutes.+type FHOUR = Double++-- | Fractional seconds.+type FSEC = Double++-- | Fractional minutes and seconds (mm.ss, ie. 01.45 is 1 minute and 45 seconds).+type FMINSEC = Double++-- * T.UTCTime format strings.++-- | 'T.parseTimeOrError' with 'T.defaultTimeLocale'.+parse_time_str :: T.ParseTime t => String -> String -> t+parse_time_str = T.parseTimeOrError True T.defaultTimeLocale++format_time_str :: T.FormatTime t => String -> t -> String+format_time_str = T.formatTime T.defaultTimeLocale++-- * ISO-8601++-- | Parse date in ISO-8601 extended (@YYYY-MM-DD@) or basic (@YYYYMMDD@) form.+--+-- > T.toGregorian (T.utctDay (parse_iso8601_date "2011-10-09")) == (2011,10,09)+-- > T.toGregorian (T.utctDay (parse_iso8601_date "20190803")) == (2019,08,03)+parse_iso8601_date :: String -> T.UTCTime+parse_iso8601_date s =+  case length s of+    8 -> parse_time_str "%Y%m%d" s -- basic+    10 -> parse_time_str "%F" s -- extended+    _ -> error "parse_iso8601_date?"++-- | Format date in ISO-8601 form.+--+-- > format_iso8601_date True (parse_iso8601_date "2011-10-09") == "2011-10-09"+-- > format_iso8601_date False (parse_iso8601_date "20190803") == "20190803"+format_iso8601_date :: T.FormatTime t => Bool -> t -> String+format_iso8601_date ext = if ext then format_time_str "%F" else format_time_str "%Y%m%d"++{- | Format date in ISO-8601 (@YYYY-WWW@) form.++> r = ["2016-W52","2011-W40"]+> map (format_iso8601_week . parse_iso8601_date) ["2017-01-01","2011-10-09"] == r++-}+format_iso8601_week :: T.FormatTime t => t -> String+format_iso8601_week = format_time_str "%G-W%V"++-- | Parse ISO-8601 time is extended (@HH:MM:SS@) or basic (@HHMMSS@) form.+--+-- > format_iso8601_time True (parse_iso8601_time "21:44:00") == "21:44:00"+-- > format_iso8601_time False (parse_iso8601_time "172511") == "172511"+parse_iso8601_time :: String -> T.UTCTime+parse_iso8601_time s =+  case length s of+    6 -> parse_time_str "%H%M%S" s -- basic+    8 -> parse_time_str "%H:%M:%S" s -- extended+    _ -> error "parse_iso8601_time?"++-- | Format time in ISO-8601 form.+--+-- > format_iso8601_time True (parse_iso8601_date_time "2011-10-09T21:44:00") == "21:44:00"+-- > format_iso8601_time False (parse_iso8601_date_time "20190803T172511") == "172511"+format_iso8601_time :: T.FormatTime t => Bool -> t -> String+format_iso8601_time ext = format_time_str (if ext then "%H:%M:%S" else "%H%M%S")++-- | Parse date and time in extended or basic forms.+--+-- > T.utctDayTime (parse_iso8601_date_time "2011-10-09T21:44:00") == T.secondsToDiffTime 78240+-- > T.utctDayTime (parse_iso8601_date_time "20190803T172511") == T.secondsToDiffTime 62711+parse_iso8601_date_time :: String -> T.UTCTime+parse_iso8601_date_time s =+  case length s of+    15 -> parse_time_str "%Y%m%dT%H%M%S" s -- basic+    19 -> parse_time_str "%FT%H:%M:%S" s -- extended+    _ -> error "parse_iso8601_date_time?"++{- | Format date in @YYYY-MM-DD@ and time in @HH:MM:SS@ forms.++> t = parse_iso8601_date_time "2011-10-09T21:44:00"+> format_iso8601_date_time True t == "2011-10-09T21:44:00"+> format_iso8601_date_time False t == "20111009T214400"++-}+format_iso8601_date_time :: T.FormatTime t => Bool -> t -> String+format_iso8601_date_time ext = format_time_str (if ext then "%FT%H:%M:%S" else "%Y%m%dT%H%M%S")++-- * FSEC++-- | Translate fractional seconds to picoseconds.+--+-- > fsec_to_picoseconds 78240.05+fsec_to_picoseconds :: FSEC -> Integer+fsec_to_picoseconds s = floor (s * (10 ** 12))++fsec_to_difftime :: FSEC -> T.DiffTime+fsec_to_difftime = T.picosecondsToDiffTime . fsec_to_picoseconds++-- * FMINSEC++-- | Translate fractional minutes.seconds to picoseconds.+--+-- > map fminsec_to_fsec [0.45,15.355] == [45,935.5]+fminsec_to_fsec :: FMINSEC -> FSEC+fminsec_to_fsec n =+    let m = ffloor n+        s = (n - m) * 100+    in (m * 60) + s++fminsec_to_sec_generic :: (RealFrac f,Integral i) => f -> i+fminsec_to_sec_generic n =+    let m = floor n+        s = round ((n - fromIntegral m) * 100)+    in (m * 60) + s++-- | Fractional minutes are mm.ss, so that 15.35 is 15 minutes and 35 seconds.+--+-- > map fminsec_to_sec [0.45,15.35] == [45,935]+fminsec_to_sec :: FMINSEC -> SEC+fminsec_to_sec = fminsec_to_sec_generic++-- > fsec_to_fminsec 935.5 == 15.355+fsec_to_fminsec :: FSEC -> FMINSEC+fsec_to_fminsec n =+    let m = ffloor (n / 60)+        s = n - (m * 60)+    in m + (s / 100)++-- > sec_to_fminsec 935 == 15.35+sec_to_fminsec :: SEC -> FMINSEC+sec_to_fminsec n =+    let m = ffloor (fromIntegral n / 60)+        s = fromIntegral n - (m * 60)+    in m + (s / 100)++-- > fminsec_add 1.30 0.45 == 2.15+-- > fminsec_add 1.30 0.45 == 2.15+fminsec_add :: BinOp FMINSEC+fminsec_add p q = fsec_to_fminsec (fminsec_to_fsec p + fminsec_to_fsec q)++fminsec_sub :: BinOp FMINSEC+fminsec_sub p q = fsec_to_fminsec (fminsec_to_fsec p - fminsec_to_fsec q)++-- > fminsec_mul 0.45 2 == 1.30+fminsec_mul :: BinOp FMINSEC+fminsec_mul t n = fsec_to_fminsec (fminsec_to_fsec t * n)++-- * FHOUR++-- | Type specialised 'fromInteger' of 'floor'.+ffloor :: Double -> Double+ffloor = fromInteger . floor++-- | Fractional hour to (hours,minutes,seconds).+--+-- > fhour_to_hms 21.75 == (21,45,0)+fhour_to_hms :: FHOUR -> HMS+fhour_to_hms h =+    let m = (h - ffloor h) * 60+        s = (m - ffloor m) * 60+    in (floor h,floor m,round s)++-- | HMS to fractional hours.+--+-- > hms_to_fhour (21,45,0) == 21.75+hms_to_fhour :: HMS -> FHOUR+hms_to_fhour (h,m,s) = fromIntegral h + (fromIntegral m / 60) + (fromIntegral s / (60 * 60))++-- | Fractional hour to seconds.+--+-- > fhour_to_fsec 21.75 == 78300.0+fhour_to_fsec :: FHOUR -> FSEC+fhour_to_fsec = (*) (60 * 60)++fhour_to_difftime :: FHOUR -> T.DiffTime+fhour_to_difftime = fsec_to_difftime . fhour_to_fsec++-- * FDAY++-- | Time in fractional days.+--+-- > round (utctime_to_fday (parse_iso8601_date_time "2011-10-09T09:00:00")) == 55843+-- > round (utctime_to_fday (parse_iso8601_date_time "2011-10-09T21:00:00")) == 55844+utctime_to_fday :: T.UTCTime -> FDAY+utctime_to_fday t =+    let d = T.utctDay t+        d' = fromIntegral (T.toModifiedJulianDay d)+        s = T.utctDayTime t+        s_max = 86401+    in d' + (fromRational (toRational s) / s_max)++-- * DiffTime++-- | 'T.DiffTime' in fractional seconds.+--+-- > difftime_to_fsec (hms_to_difftime (21,44,30)) == 78270+difftime_to_fsec :: T.DiffTime -> FSEC+difftime_to_fsec = fromRational . toRational++-- | 'T.DiffTime' in fractional minutes.+--+-- > difftime_to_fmin (hms_to_difftime (21,44,30)) == 1304.5+difftime_to_fmin :: T.DiffTime -> Double+difftime_to_fmin = (/ 60) . difftime_to_fsec++-- | 'T.DiffTime' in fractional hours.+--+-- > difftime_to_fhour (hms_to_difftime (21,45,00)) == 21.75+difftime_to_fhour :: T.DiffTime -> FHOUR+difftime_to_fhour = (/ 60) . difftime_to_fmin++hms_to_difftime :: HMS -> T.DiffTime+hms_to_difftime = fhour_to_difftime . hms_to_fhour++-- * HMS++hms_to_sec :: HMS -> SEC+hms_to_sec (h,m,s) = h * 60 * 60 + m * 60 + s++-- | Seconds to (hours,minutes,seconds).+--+-- > map sec_to_hms [60-1,60+1,60*60-1,60*60+1] == [(0,0,59),(0,1,1),(0,59,59),(1,0,1)]+sec_to_hms :: SEC -> HMS+sec_to_hms s =+  let (h,s') = s `divMod` (60 * 60)+      (m,s'') = sec_to_minsec s'+  in (h,m,s'')++-- | 'HMS' pretty printer.+--+-- > map (hms_pp True) [(0,1,2),(1,2,3)] == ["01:02","01:02:03"]+hms_pp :: Bool -> HMS -> String+hms_pp trunc (h,m,s) =+  if trunc && h == 0+  then printf "%02d:%02d" m s+  else printf "%02d:%02d:%02d" h m s++-- * 'HMS' parser.+--+-- > hms_parse "0:01:00" == (0,1,0)+hms_parse :: String -> HMS+hms_parse x =+    case splitOn ":" x of+      [h,m,s] -> (read h,read m,read s)+      _ -> error "parse_hms"++-- * MINSEC+ -- | 'divMod' by @60@. -- -- > sec_to_minsec 123 == (2,3)@@ -30,6 +311,7 @@ minsec_to_sec :: Num n => MinSec n -> n minsec_to_sec (m,s) = m * 60 + s +-- | Convert /p/ and /q/ to seconds, apply /f/, and convert back to 'MinSec'. minsec_binop :: Integral t => (t -> t -> t) -> MinSec t -> MinSec t -> MinSec t minsec_binop f p q = sec_to_minsec (f (minsec_to_sec p) (minsec_to_sec q)) @@ -57,7 +339,7 @@ minsec_sum :: Integral n => [MinSec n] -> MinSec n minsec_sum = foldl minsec_add (0,0) --- | Fractional seconds to @(min,sec)@.+-- | 'round' 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@@ -76,6 +358,8 @@       [m,s] -> (read m,read s)       _ -> error "parse_minsec" +-- * MINCSEC+ -- | Fractional seconds to @(min,sec,csec)@, csec value is 'round'ed. -- -- > map fsec_to_mincsec [1,1.5,4/3] == [(0,1,0),(0,1,50),(0,1,33)]@@ -121,6 +405,60 @@  mincsec_binop :: Integral t => (t -> t -> t) -> MinCsec t -> MinCsec t -> MinCsec t mincsec_binop f p q = csec_to_mincsec (f (mincsec_to_csec p) (mincsec_to_csec q))++-- * DHMS++-- | Convert seconds into (days,hours,minutes,seconds).+sec_to_dhms_generic :: Integral n => n -> (n,n,n,n)+sec_to_dhms_generic n =+    let (d,h') = n `divMod` (24 * 60 * 60)+        (h,m') = h' `divMod` (60 * 60)+        (m,s) = m' `divMod` 60+    in (d,h,m,s)++-- | Type specialised 'sec_to_dhms_generic'.+--+-- > sec_to_dhms 1475469 == (17,1,51,9)+sec_to_dhms :: SEC -> DHMS+sec_to_dhms = sec_to_dhms_generic++-- | Inverse of 'seconds_to_dhms'.+--+-- > dhms_to_sec (17,1,51,9) == 1475469+dhms_to_sec :: Num n => (n,n,n,n) -> n+dhms_to_sec (d,h,m,s) = sum [d * 24 * 60 * 60,h * 60 * 60,m * 60,s]++-- | Generic form of 'parse_dhms'.+parse_dhms_generic :: (Integral n,Read n) => String -> (n,n,n,n)+parse_dhms_generic =+    let sep_elem = split . keepDelimsR . oneOf+        sep_last x = let e:x' = reverse x in (reverse x',e)+        p x = case sep_last x of+                (n,'d') -> read n * 24 * 60 * 60+                (n,'h') -> read n * 60 * 60+                (n,'m') -> read n * 60+                (n,'s') -> read n+                _ -> error "parse_dhms"+    in sec_to_dhms_generic . sum . map p . filter (not . null) . sep_elem "dhms"++-- | Parse DHMS text.  All parts are optional, order is not+-- significant, multiple entries are allowed.+--+-- > parse_dhms "17d1h51m9s" == (17,1,51,9)+-- > parse_dhms "1s3d" == (3,0,0,1)+-- > parse_dhms "1h1h" == (0,2,0,0)+parse_dhms :: String -> DHMS+parse_dhms = parse_dhms_generic++-- * WEEK++-- | Week that /t/ lies in.+--+-- > map (time_to_week . parse_iso8601_date) ["2017-01-01","2011-10-09"] == [52,40]+time_to_week :: T.UTCTime -> WEEK+time_to_week = read . format_time_str "%V"++-- * UTIL  -- | Given printer, pretty print time span. span_pp :: (t -> String) -> (t,t) -> String
Music/Theory/Time/Seq.hs view
@@ -1,15 +1,16 @@ -- | Basic temporal sequence functions. module Music.Theory.Time.Seq where +import Data.Bifunctor {- base -} 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.Ratio {- base -} import Safe {- safe -} -import Music.Theory.Function {- hmt -}+import qualified Data.List.Ordered as O {- data-ordlist -}+import qualified Data.Map as M {- containers -}+ import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Math as T {- hmt -} import qualified Music.Theory.Ord as T {- hmt -}@@ -20,41 +21,48 @@ -- | 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/.+-- | Duration sequence.+-- /t/ indicates the /forward/ duration of the value, ie. the interval to the next value.+-- If there are other durations they must be encoded at /a/.+-- If the sequence does not begin at time zero there must be an /empty/ value for /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--- a /nil/ (end of sequence) value.+-- | Inter-offset sequence.+-- /t/ is the interval /before/ the value.+-- Duration can be encoded at /a/, or if implicit /a/ must include an end of sequence value. type Iseq t a = [(t,a)] --- | Pattern sequence.  The duration is a triple of /logical/,--- /sounding/ and /forward/ durations.+-- | Pattern sequence.+-- The duration is a triple of /logical/, /sounding/ and /forward/ durations.+-- Ie. the time it conceptually takes, the time it actually takes, and the time to the next event. type Pseq t a = [((t,t,t),a)] --- | Time-point sequence.  To express holes /a/ must have an /empty/--- value.  To indicate the duration of the final value /a/ must have--- a /nil/ (end of sequence) value.+-- | Time-point sequence.+-- /t/ is the start-time of the value.+-- To express holes /a/ must have an /empty/ value.+-- Duration can be encoded at /a/, or if implicit /a/ must include an 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 '>'.+-- | Window sequence.+-- /t/ is a duple of /start-time/ and /duration/.+-- Holes exist where @st(n) + du(n)@ '<' @st(n+1)@.+-- Overlaps exist where the same relation is '>'. type Wseq t a = [((t,t),a)]  -- * Zip +-- | Construct 'Pseq'. pseq_zip :: [t] -> [t] -> [t] -> [a] -> Pseq t a pseq_zip l o f a = (zip (zip3 l o f) a) +-- | Construct 'Wseq'. 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.+-- | Given functions for deriving start and end times calculate time span of sequence.+--   Requires sequence be finite. -- -- > seq_tspan id id [] == (0,0) -- > seq_tspan id id (zip [0..9] ['a'..]) == (0,9)@@ -63,9 +71,11 @@     (maybe 0 (st . fst) (headMay sq)     ,maybe 0 (et . fst) (lastMay sq)) +-- | 'seq_tspan' for 'Tseq'. tseq_tspan :: Num t => Tseq t a -> (t,t) tseq_tspan = seq_tspan id id +-- | 'seq_tspan' for 'Wseq'. wseq_tspan :: Num t => Wseq t a -> (t,t) wseq_tspan = seq_tspan fst (uncurry (+)) @@ -85,22 +95,25 @@  -- * Duration +-- | Sum durations at 'Dseq', result is the end time of the last element. dseq_dur :: Num t => Dseq t a -> t dseq_dur = sum . map fst +-- | Sum durations at 'Iseq', result is the start time of the last element. iseq_dur :: Num t => Iseq t a -> t iseq_dur = sum . map fst +-- | Sum durations at 'Pseq', result is the end time of the last element. pseq_dur :: Num t => Pseq t a -> t pseq_dur = sum . map (T.t3_third . fst) --- | The interval of 'tseq_tspan'.+-- | The interval of 'tseq_tspan', ie. from the start of the first element to the start of the last. -- -- > 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'.+-- | The interval of 'wseq_tspan', ie. from the start of the first element to the end of the last. -- -- > wseq_dur (zip (zip [0..] (repeat 2)) "abcde") == 6 wseq_dur :: Num t => Wseq t a -> t@@ -108,8 +121,7 @@  -- * Window --- | Prefix of sequence where the start time precedes or is at the--- indicate time.+-- | Prefix of sequence where the start time precedes or is at the indicated time. wseq_until :: Ord t => t -> Wseq t a -> Wseq t a wseq_until tm = takeWhile (\((t0,_),_) -> t0 <= tm) @@ -118,7 +130,7 @@ -- edges, ie. [t0,t1].  Halts processing at end of window. -- -- > let r = [((5,1),'e'),((6,1),'f'),((7,1),'g'),((8,1),'h')]--- > in wseq_twindow (5,9) (zip (zip [1..] (repeat 1)) ['a'..]) == r+-- > wseq_twindow (5,9) (zip (zip [1..] (repeat 1)) ['a'..]) == r -- -- > wseq_twindow (1,2) [((1,1),'a'),((1,2),'b')] == [((1,1),'a')] wseq_twindow :: (Num t, Ord t) => (t,t) -> Wseq t a -> Wseq t a@@ -131,7 +143,7 @@ -- of window. -- -- > let sq = [((1,1),'a'),((1,2),'b')]--- > in map (wseq_at sq) [1,2] == [sq,[((1,2),'b')]]+-- > map (wseq_at sq) [1,2] == [sq,[((1,2),'b')]] -- -- > wseq_at (zip (zip [1..] (repeat 1)) ['a'..]) 3 == [((3,1),'c')] wseq_at :: (Num t,Ord t) => Wseq t a -> t -> Wseq t a@@ -145,7 +157,7 @@ -- of window. -- -- > let sq = [((0,2),'a'),((0,4),'b'),((2,4),'c')]--- > in wseq_at_window sq (1,3) == sq+-- > wseq_at_window sq (1,3) == sq -- -- > wseq_at_window (zip (zip [1..] (repeat 1)) ['a'..]) (3,4) == [((3,1),'c'),((4,1),'d')] wseq_at_window :: (Num t, Ord t) => Wseq t a -> (t,t) -> Wseq t a@@ -156,12 +168,15 @@  -- * Append +-- | Type specialised '++' dseq_append :: Dseq t a -> Dseq t a -> Dseq t a dseq_append = (++) +-- | Type specialised '++' iseq_append :: Iseq t a -> Iseq t a -> Iseq t a iseq_append = (++) +-- | Type specialised '++' pseq_append :: Pseq t a -> Pseq t a -> Pseq t a pseq_append = (++) @@ -237,6 +252,7 @@  -- * Lseq +-- | Iterpolation type enumeration. data Interpolation_T = None | Linear                      deriving (Eq,Enum,Show) @@ -272,24 +288,31 @@  -- * Map, Filter, Find -seq_tmap :: (t -> t') -> [(t,a)] -> [(t',a)]+-- | 'map' over time (/t/) data.+seq_tmap :: (t1 -> t2) -> [(t1,a)] -> [(t2,a)] seq_tmap f = map (\(p,q) -> (f p,q)) -seq_map :: (b -> c) -> [(a,b)] -> [(a,c)]+-- | 'map' over element (/e/) data.+seq_map :: (e1 -> e2) -> [(t,e1)] -> [(t,e2)] 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))+-- | 'map' /t/ and /e/ simultaneously.+--+-- > seq_bimap negate succ (zip [1..5] [0..4]) == [(-1,1),(-2,2),(-3,3),(-4,4),(-5,5)]+seq_bimap :: (t1 -> t2) -> (e1 -> e2) -> [(t1,e1)] -> [(t2,e2)]+seq_bimap f = map . bimap f +-- | 'filter' over time (/t/) data. seq_tfilter :: (t -> Bool) -> [(t,a)] -> [(t,a)] seq_tfilter f = filter (f . fst) +-- | 'filter' over element (/e/) data. 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'+-- | 'find' over element (/e/) data.+seq_find :: (e -> Bool) -> [(t,e)] -> Maybe (t,e)+seq_find f = find (f . snd)  -- * Maybe @@ -303,10 +326,7 @@ 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+-- | If value is unchanged at subsequent entry, according to /f/, replace with 'Nothing'. seq_changed_by :: (a -> a -> Bool) -> [(t,a)] -> [(t,Maybe a)] seq_changed_by f l =     let recur z sq =@@ -320,6 +340,9 @@          (t,e) : l' -> (t,Just e) : recur e l'  -- | 'seq_changed_by' '=='.+--+-- > let r = [(1,'s'),(2,'t'),(4,'r'),(6,'i'),(7,'n'),(9,'g')]+-- > seq_cat_maybes (seq_changed (zip [1..] "sttrrinng")) == r seq_changed :: Eq a => [(t,a)] -> [(t,Maybe a)] seq_changed = seq_changed_by (==) @@ -327,11 +350,11 @@  -- | 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+wseq_tmap_st f = seq_tmap (bimap f id)  -- | 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+wseq_tmap_dur f = seq_tmap (bimap id f)  -- * Partition @@ -347,13 +370,14 @@  -- | 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)]+-- > let p = zip [0,1,3,5] (zip (repeat 0) "abcd")+-- > let q = zip [2,4,6,7] (zip (repeat 1) "ABCD")+-- > let sq = tseq_merge p q+-- > 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 +-- | Type specialised 'seq_partition'. wseq_partition :: Ord v => (a -> v) -> Wseq t a -> [(v,Wseq t a)] wseq_partition = seq_partition @@ -385,7 +409,7 @@ -- /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 (==) 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@@ -400,9 +424,9 @@ -- '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+-- > let d = useq_to_dseq (1,"abbcccdde")+-- > let r = dseq_coalesce (==) const d+-- > 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)@@ -422,6 +446,7 @@ tseq_tcoalesce :: Eq t => (a -> a -> a) -> Tseq t a -> Tseq t a tseq_tcoalesce = seq_tcoalesce (==) +-- | Type specialised 'seq_tcoalesce'. wseq_tcoalesce :: ((t,t) -> (t,t) -> Bool) -> (a -> a -> a) -> Wseq t a -> Wseq t a wseq_tcoalesce = seq_tcoalesce @@ -430,7 +455,7 @@ -- | 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 (==) (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@@ -442,7 +467,7 @@ -- | 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 (zip [0,1,1,2,2,3] ['a'..]) == r -- -- > tseq_group [(1,'a'),(1,'b')] == [(1,"ab")] -- > tseq_group [(1,'a'),(2,'b'),(2,'c')] == [(1,"a"),(2,"bc")]@@ -452,16 +477,17 @@ -- | 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 (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.+--   For entries with the same start time this leads to zero durations. ----- > 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+-- > let r = wseq_zip [0,3,3,5] [3,0,2,1] "abcd"+-- > wseq_fill_dur (wseq_zip [0,3,3,5] [2,1,2,1] "abcd") == 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)@@ -479,6 +505,10 @@         t_f n = T.rational_whole_err (n * fromIntegral m)     in map (dseq_tmap t_f) sq +-- | End-time of sequence (ie. sum of durations).+dseq_end :: Num t => Dseq t a -> t+dseq_end = sum . map fst+ -- * Tseq  -- | Given a a default value, a 'Tseq' /sq/ and a list of time-points@@ -497,6 +527,14 @@                                    EQ -> (sq_t,sq_e) : tseq_latch sq_e sq' t'                                    GT -> (t0,def) : tseq_latch def sq t' +-- | End-time of sequence (ie. time of last event).+tseq_end :: Tseq t a -> t+tseq_end = fst . last++-- | Append the value /nil/ at /n/ seconds after the end of the sequence.+tseq_add_nil_after :: Num t => a -> t -> Tseq t a -> Tseq t a+tseq_add_nil_after nil n sq = sq ++ [(tseq_end sq + n,nil)]+ -- * Wseq  -- | Sort 'Wseq' by start time, 'Wseq' ought never to be out of@@ -506,56 +544,90 @@ wseq_sort :: Ord t => Wseq t a -> Wseq t a wseq_sort = sortBy (compare `on` (fst . fst)) --- | Transform 'Wseq' to 'Tseq' by discaring durations.+-- | Transform 'Wseq' to 'Tseq' by discarding durations. wseq_discard_dur :: Wseq t a -> Tseq t a wseq_discard_dur = let f ((t,_),e) = (t,e) in map f -wseq_overlap_f :: (Eq e,Ord t,Num t) =>-                  (e -> e -> Bool) -> (t -> t) -> ((t,t),e) -> Wseq t e -> Maybe (Wseq t e)-wseq_overlap_f eq_fn dur_fn ((t,d),a) sq =-  case find (eq_fn a . snd) sq of-    Nothing -> Nothing-    Just ((t',d'),a') ->-      if t == t'-      then if d <= d'-           then Just sq -- delete LHS-           else Just (((t,d),a) : delete ((t',d'),a') sq) -- delete RHS-      else if t' < t + d-           then Just (((t,dur_fn (t' - t)),a) : sq) -- truncate LHS-           else Nothing+-- | Are /e/ equal and do nodes overlap?+--   Nodes are ascending, and so overlap if:+--   1. they begin at the same time and the first has non-zero duration, or+--   2. the second begins before the first ends.+wseq_nodes_overlap :: (Ord t,Num t) => (e -> e -> Bool) -> ((t,t),e) -> ((t,t),e) -> Bool+wseq_nodes_overlap eq_f ((t1,d1),a1) ((t2,_d2),a2) =+  eq_f a1 a2 && ((t1 == t2 && d1 > 0) || (t2 < (t1 + d1))) --- | Determine if sequence has overlapping equal nodes.-wseq_has_overlaps :: (Ord t, Num t, Eq e) => (e -> e -> Bool) -> Wseq t e -> Bool+-- | Find first node at /sq/ that overlaps with /e0/, if there is one.+--   Note: this could, but does not, halt early, ie. when t2 > (t1 + d1).+wseq_find_overlap_1 :: (Ord t,Num t) => (e -> e -> Bool) -> ((t,t),e) -> Wseq t e -> Bool+wseq_find_overlap_1 eq_f e0 = isJust . find (wseq_nodes_overlap eq_f e0)++-- | Determine if sequence has any overlapping equal nodes, stops after finding first instance.+--+-- > wseq_has_overlaps (==) [] == False+-- > wseq_has_overlaps (==) [((0,1),'x')]+wseq_has_overlaps :: (Ord t, Num t) => (e -> e -> Bool) -> Wseq t e -> Bool wseq_has_overlaps eq_fn =   let recur sq =         case sq of           [] -> False-          h:sq' ->-            case wseq_overlap_f eq_fn id h sq' of-              Nothing -> recur sq'-              Just _ -> True-    in recur+          e0:sq' -> if wseq_find_overlap_1 eq_fn e0 sq' then True else recur sq'+  in recur +{- | Remove overlaps by deleting any overlapping nodes. -{- | Edit durations to ensure that nodes don't overlap.  If equal nodes-     begin simultaneously delete the shorter node.  If a node-     extends into a later node shorten the initial duration (apply /dur_fn/ to iot).+> let sq = [((0,1),'a'),((0,5),'a'),((1,5),'a'),((3,1),'a')]+> wseq_has_overlaps (==) sq == True+> let sq_rw = wseq_remove_overlaps_rm (==) sq+> sq_rw == [((0,1),'a'),((1,5),'a')]+> wseq_has_overlaps (==) sq_rw+-}+wseq_remove_overlaps_rm :: (Ord t,Num t) => (e -> e -> Bool) -> Wseq t e -> Wseq t e+wseq_remove_overlaps_rm eq_f =+  let recur sq =+        case sq of+          [] -> []+          e0:sq' -> e0 : recur (filter (not . wseq_nodes_overlap eq_f e0) sq')+  in recur +{- | Find first instance of overlap of /e/ at /sq/ and re-write durations so nodes don't overlap.+     If equal nodes begin simultaneously delete the shorter node (eithe LHS or RHS).+     If a node extends into a later node shorten the initial (LHS) duration (apply /dur_fn/ to iot).+-}+wseq_remove_overlap_rw_1 :: (Ord t,Num t) =>+                            (e -> e -> Bool) -> (t -> t) -> ((t,t),e) -> Wseq t e -> Maybe (Wseq t e)+wseq_remove_overlap_rw_1 eq_f dur_fn ((t,d),a) sq =+  let n_eq ((t1,d1),e1) ((t2,d2),e2) = t1 == t2 && d1 == d2 && eq_f e1 e2+  in case find (eq_f a . snd) sq of+       Nothing -> Nothing+       Just ((t',d'),a') ->+         if t == t'+         then if d <= d'+         then Just sq -- delete LHS+              else Just (((t,d),a) : deleteBy n_eq ((t',d'),a') sq) -- delete RHS+         else if t' < t + d+              then Just (((t,dur_fn (t' - t)),a) : sq) -- truncate LHS+              else Nothing++{- | Run 'wseq_remove_overlap_rw_1' until sequence has no overlaps.+ > let sq = [((0,1),'a'),((0,5),'a'),((1,5),'a'),((3,1),'a')]-> let r = [((0,1),'a'),((1,2),'a'),((3,1),'a')] > wseq_has_overlaps (==) sq == True-> wseq_remove_overlaps (==) id sq == r-> wseq_has_overlaps (==) (wseq_remove_overlaps (==) id sq) == False+> let sq_rw = wseq_remove_overlaps_rw (==) id sq+> sq_rw == [((0,1),'a'),((1,2),'a'),((3,1),'a')]+> wseq_has_overlaps (==) sq_rw == False +> import qualified Music.Theory.Array.CSV.Midi.MND as T {- hmt -}+> let csv_fn = "/home/rohan/uc/the-center-is-between-us/visitants/csv/midi/air.B.1.csv"+> sq <- T.csv_midi_read_wseq csv_fn :: IO (Wseq Double (T.Event Double))+ -}-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 dur_fn =+wseq_remove_overlaps_rw :: (Ord t,Num t) => (e -> e -> Bool) -> (t -> t) -> Wseq t e -> Wseq t e+wseq_remove_overlaps_rw eq_f dur_fn =   let recur sq =         case sq of           [] -> []           h:sq' ->-            case wseq_overlap_f eq_fn dur_fn h sq' of+            case wseq_remove_overlap_rw_1 eq_f dur_fn h sq' of               Nothing -> h : recur sq'               Just sq'' -> recur sq''     in recur@@ -564,7 +636,7 @@ seq_unjoin :: [(t,[e])] -> [(t,e)] seq_unjoin = let f (t,e) = zip (repeat t) e in concatMap f --- | Type specialised.+-- | Type specialised 'seq_unjoin'. wseq_unjoin :: Wseq t [e] -> Wseq t e wseq_unjoin = seq_unjoin @@ -586,6 +658,10 @@ wseq_concat :: Num t => [Wseq t a] -> Wseq t a wseq_concat = foldl1 wseq_append +-- | Transform sequence to start at time zero.+wseq_zero :: Num t => Wseq t a -> Wseq t a+wseq_zero sq = let t0 = wseq_start sq in wseq_tmap (\(st,du) -> (st - t0,du)) sq+ -- * Begin/End  -- | Container to mark the /begin/ and /end/ of a value.@@ -598,6 +674,8 @@       Begin a -> Begin (f a)       End a -> End (f a) +instance Functor Begin_End where fmap = begin_end_map+ -- | Structural comparison at 'Begin_End', 'Begin' compares less than 'End'. cmp_begin_end :: Begin_End a -> Begin_End b -> Ordering cmp_begin_end p q =@@ -607,6 +685,8 @@       (End _,End _) -> EQ       (End _,Begin _) -> GT +--instance Eq t => Ord (Begin_End t) where compare = cmp_begin_end+ -- | Translate container types. either_to_begin_end :: Either a a -> Begin_End a either_to_begin_end p =@@ -621,6 +701,7 @@       Begin a -> Left a       End a -> Right a +-- | Equivalent to 'partitionEithers'. begin_end_partition :: [Begin_End a] -> ([a],[a]) begin_end_partition =   let f e (p,q) = case e of@@ -628,32 +709,35 @@                     End x -> (p,x:q)   in foldr f ([],[]) --- | Add or delete element from accumulated state.-begin_end_track :: Eq a => [a] -> Begin_End a -> [a]-begin_end_track st e =+-- | Add or delete element from accumulated state given equality function.+begin_end_track_by :: (a -> a -> Bool) -> [a] -> Begin_End a -> [a]+begin_end_track_by eq_f st e =   case e of     Begin x -> x : st-    End x -> delete x st+    End x -> deleteBy eq_f x st --- | Convert 'Wseq' to 'Tseq' transforming elements to 'Begin_End'.---   When merging, /end/ elements precede /begin/ elements at equal times.------ > let {sq = [((0,5),'a'),((2,2),'b')]--- >     ;r = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End 'a')]}--- > in wseq_begin_end sq == r------ > let {sq = [((0,1),'a'),((1,1),'b'),((2,1),'c')]--- >     ;r = [(0,Begin 'a'),(1,End 'a')--- >          ,(1,Begin 'b'),(2,End 'b')--- >          ,(2,Begin 'c'),(3,End 'c')]}--- > in wseq_begin_end sq == r+-- | 'begin_end_track_by' of '=='.+begin_end_track :: Eq a => [a] -> Begin_End a -> [a]+begin_end_track = begin_end_track_by (==)++{- | Convert 'Wseq' to 'Tseq' transforming elements to 'Begin_End'.+     When merging, /end/ elements precede /begin/ elements at equal times.++> let sq = [((0,5),'a'),((2,2),'b')]+> let r = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End 'a')]+> wseq_begin_end sq == r++> let sq = [((0,1),'a'),((1,1),'b'),((2,1),'c')]+> let r = [(0,Begin 'a'),(1,End 'a'),(1,Begin 'b'),(2,End 'b'),(2,Begin 'c'),(3,End 'c')]+> wseq_begin_end sq == r+-} wseq_begin_end :: (Num t, Ord t) => Wseq t a -> Tseq t (Begin_End a) wseq_begin_end sq =     let f ((t,d),a) = [(t,Begin a),(t + d,End a)]         g l =             case l of               [] -> []-              e:l' -> tseq_merge_by (T.ord_invert .: cmp_begin_end) e (g l')+              e:l' -> tseq_merge_by (\x -> T.ord_invert . cmp_begin_end x) e (g l')     in g (map f sq)  -- | 'begin_end_to_either' of 'wseq_begin_end'.@@ -662,13 +746,13 @@  -- | Variant that applies /begin/ and /end/ functions to nodes. ----- > let {sq = [((0,5),'a'),((2,2),'b')]--- >     ;r = [(0,'A'),(2,'B'),(4,'b'),(5,'a')]}--- > in wseq_begin_end_f Data.Char.toUpper id sq == r+-- > let sq = [((0,5),'a'),((2,2),'b')]+-- > let r = [(0,'A'),(2,'B'),(4,'b'),(5,'a')]+-- > wseq_begin_end_f Data.Char.toUpper id sq == r wseq_begin_end_f :: (Ord t,Num t) => (a -> b) -> (a -> b) -> Wseq t a -> Tseq t b wseq_begin_end_f f g = tseq_map (either f g) . wseq_begin_end_either --- | Result for each time-point the triple (begin-list,end-list,hold-list).+-- | Generate for each time-point the triple (begin-list,end-list,hold-list). --   The elements of the end-list have been deleted from the hold list. tseq_begin_end_accum :: Eq a => Tseq t [Begin_End a] -> Tseq t ([a],[a],[a]) tseq_begin_end_accum =@@ -678,6 +762,15 @@             in (st',(t,(b,e,st \\ e)))     in snd . mapAccumL f [] +-- | Variant that initially transforms 'Wseq' into non-overlapping begin-end sequence.+--   If the sequence was edited for overlaps this is indicated.+wseq_begin_end_accum :: (Eq e, Ord t, Num t) => Wseq t e -> (Bool, Tseq t ([e],[e],[e]))+wseq_begin_end_accum sq =+  let ol = wseq_has_overlaps (==) sq+      sq_edit = if ol then wseq_remove_overlaps_rw (==) id sq else sq+      a_sq = tseq_begin_end_accum (tseq_group (wseq_begin_end sq_edit))+  in (ol,a_sq)+ tseq_accumulate :: Eq a => Tseq t [Begin_End a] -> Tseq t [a] tseq_accumulate =   let f st (t,e) =@@ -695,9 +788,9 @@ -- | Inverse of 'wseq_begin_end' given a predicate function for locating -- the /end/ node of a /begin/ node. ----- > let {sq = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End 'a')]--- >     ;r = [((0,5),'a'),((2,2),'b')]}--- > in tseq_begin_end_to_wseq (==) sq == r+-- > let sq = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End 'a')]+-- > let r = [((0,5),'a'),((2,2),'b')]+-- > tseq_begin_end_to_wseq (==) sq == r tseq_begin_end_to_wseq :: Num t => (a -> a -> Bool) -> Tseq t (Begin_End a) -> Wseq t a tseq_begin_end_to_wseq cmp =     let cmp' x e =@@ -725,31 +818,34 @@ -- /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+-- > 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+-- > let d = zip [1,2,3,2,1] "abcde"+-- > let r = zip [0,1,3,6,8,9,10] "abcdeab"+-- > 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'+dseq_to_tseq t0 nil = T.rezip (T.dx_d t0) (T.snoc nil)  -- | Variant where the /nil/ value is taken from the last element of -- the sequence. -- -- > let r = zip [0,1,3,6,8,9] "abcdee"--- > in dseq_to_tseq_last 0 (zip [1,2,3,2,1] "abcde") == r+-- > 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 +-- | 'Iseq' to 'Tseq', requires t0.+--+-- > let r = zip [1,3,6,8,9] "abcde"+-- > iseq_to_tseq 0 (zip [1,2,3,2,1] "abcde") == r+iseq_to_tseq :: Num t => t -> Iseq t a -> Tseq t a+iseq_to_tseq t0 = T.rezip (tail . T.dx_d t0) id+ -- | 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 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@@ -762,10 +858,10 @@ -- value is required in case the 'Tseq' does not begin at @0@. -- -- > let r = zip [1,2,3,2,1] "abcde"--- > in tseq_to_dseq undefined (zip [0,1,3,6,8,9] "abcde|") == r+-- > 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 '-' (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@@ -776,14 +872,14 @@  -- | 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/+-- of each value is either derived from the value, if a /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+-- > 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 (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@@ -792,7 +888,10 @@               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.+--+-- > tseq_to_iseq (zip [0,1,3,6,8,9] "abcde|") == zip [0,1,2,3,2,1] "abcde|"+tseq_to_iseq :: Num t => Tseq t a -> Iseq t a tseq_to_iseq =     let recur n p =             case p of@@ -803,7 +902,7 @@ -- | 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 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@@ -815,16 +914,16 @@ -- 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"+-- > 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"+-- > 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"+-- > 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 '-' 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,_),_)) =@@ -845,7 +944,7 @@ -- 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 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 =@@ -856,8 +955,9 @@  -- * Cycle -wseq_cycle' :: Num t => Wseq t a -> [Wseq t a]-wseq_cycle' sq =+-- | List of cycles of 'Wseq'.+wseq_cycle_ls :: Num t => Wseq t a -> [Wseq t a]+wseq_cycle_ls sq =     let (_,et) = wseq_tspan sq         t_sq = iterate (+ et) 0     in map (\x -> wseq_tmap (\(t,d) -> (x + t,d)) sq) t_sq@@ -866,19 +966,19 @@ -- -- > take 5 (wseq_cycle [((0,1),'a'),((3,3),'b')]) wseq_cycle :: Num t => Wseq t a -> Wseq t a-wseq_cycle = concat . wseq_cycle'+wseq_cycle = concat . wseq_cycle_ls  -- | Variant cycling only /n/ times. -- -- > wseq_cycle_n 3 [((0,1),'a'),((3,3),'b')] wseq_cycle_n :: Num t => Int -> Wseq t a -> Wseq t a-wseq_cycle_n n = concat . take n . wseq_cycle'+wseq_cycle_n n = concat . take n . wseq_cycle_ls  -- | 'wseq_until' of 'wseq_cycle'. wseq_cycle_until :: (Num t,Ord t) => t -> Wseq t a -> Wseq t a wseq_cycle_until et = wseq_until et . wseq_cycle --- * Type specialised map+-- * Type specialised maps  dseq_tmap :: (t -> t') -> Dseq t a -> Dseq t' a dseq_tmap = seq_tmap
Music/Theory/Tuning.hs view
@@ -1,176 +1,165 @@ -- | Tuning theory module Music.Theory.Tuning where -import Data.Fixed (mod') {- base -}-import Data.List {- base -}-import qualified Data.Map as M {- containers -}-import Data.Maybe {- base -}+import qualified Data.Fixed as Fixed {- base -} import Data.Ratio {- base -}-import Safe {- safe -} -import qualified Music.Theory.Either as T {- hmt -}+import qualified Music.Theory.Function as T {- hmt -} import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Map as T {- hmt -}-import qualified Music.Theory.Pitch as T {- hmt -}-import qualified Music.Theory.Set.List as T {- hmt -}-import qualified Music.Theory.Tuple as T {- hmt -}---- * Types---- | An approximation of a ratio.-type Approximate_Ratio = Double+import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Ord as T {- hmt -} --- | A real valued division of a semi-tone into one hundred parts, and--- hence of the octave into @1200@ parts.-type Cents = Double+-- * Math/Floating --- | A tuning specified 'Either' as a sequence of exact ratios, or as--- a sequence of possibly inexact 'Cents'.------ In both cases, the values are given in relation to the first degree--- of the scale, which for ratios is 1 and for cents 0.-data Tuning = Tuning {tn_ratios_or_cents :: Either [Rational] [Cents]-                     ,tn_octave_ratio :: Rational}-              deriving (Eq,Show)+-- | Fractional /midi/ note number to cycles per second, given frequency of ISO A4.+fmidi_to_cps_f0 :: Floating a => a -> a -> a+fmidi_to_cps_f0 f0 i = f0 * (2 ** ((i - 69) * (1 / 12))) --- | Divisions of octave.+-- | 'fmidi_to_cps_f0' 440. ----- > tn_divisions (equal_temperament 12) == 12-tn_divisions :: Tuning -> Int-tn_divisions = either length length . tn_ratios_or_cents---- | 'Maybe' exact ratios of 'Tuning'.-tn_ratios :: Tuning -> Maybe [Rational]-tn_ratios = T.fromLeft . tn_ratios_or_cents---- | 'error'ing variant.-tn_ratios_err :: Tuning -> [Rational]-tn_ratios_err = fromMaybe (error "ratios") . tn_ratios---- | Possibly inexact 'Cents' of tuning.-tn_cents :: Tuning -> [Cents]-tn_cents = either (map ratio_to_cents) id . tn_ratios_or_cents+-- > map fmidi_to_cps [69,69.1] == [440.0,442.5488940698553]+fmidi_to_cps :: Floating a => a -> a+fmidi_to_cps = fmidi_to_cps_f0 440 --- | 'map' 'round' '.' 'cents'.-tn_cents_i :: Integral i => Tuning -> [i]-tn_cents_i = map round . tn_cents+-- | /Midi/ note number to cycles per second, given frequency of ISO A4.+midi_to_cps_f0 :: (Integral i,Floating f) => f -> i -> f+midi_to_cps_f0 f0 = fmidi_to_cps_f0 f0 . fromIntegral --- | Variant of 'cents' that includes octave at right.-tn_cents_octave :: Tuning -> [Cents]-tn_cents_octave t = tn_cents t ++ [ratio_to_cents (tn_octave_ratio t)]+-- | 'midi_to_cps_f0' 440.+--+-- > map (round . midi_to_cps) [59,60,69] == [247,262,440]+midi_to_cps :: (Integral i,Floating f) => i -> f+midi_to_cps = midi_to_cps_f0 440  -- | 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)+-- > map cents_to_fratio [0,701.9550008653874,1200] == [1,3/2,2]+-- > map cents_to_fratio [-1800,1800] -- three octaves about zero+cents_to_fratio :: Floating a => a -> a+cents_to_fratio n = 2 ** (n / 1200) --- | Possibly inexact 'Approximate_Ratio's of tuning.-tn_approximate_ratios :: Tuning -> [Approximate_Ratio]-tn_approximate_ratios =-    either (map approximate_ratio) (map cents_to_ratio) .-    tn_ratios_or_cents+-- | Convert from a 'Floating' ratio to /cents/.+--+-- > let r = [0,498,702,1200]+-- > 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 --- | Cyclic form, taking into consideration 'octave_ratio'.-tn_approximate_ratios_cyclic :: Tuning -> [Approximate_Ratio]-tn_approximate_ratios_cyclic t =-    let r = tn_approximate_ratios t-        m = realToFrac (tn_octave_ratio t)-        g = iterate (* m) 1-        f n = map (* n) r-    in concatMap f g+-- | Frequency /n/ cents from /f/.+--+-- > import Music.Theory.Pitch {- hmt -}+-- > 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_fratio --- | Iterate the function /f/ /n/ times, the inital value is /x/.+-- | Interval in /cents/ from /p/ to /q/, ie. 'ratio_to_cents' of /p/ '/' /q/. ----- > recur_n 5 (* 2) 1 == 32--- > take (5 + 1) (iterate (* 2) 1) == [1,2,4,8,16,32]-recur_n :: Integral n => n -> (t -> t) -> t -> t-recur_n n f x = if n < 1 then x else recur_n (n - 1) f (f x)+-- > map (round . cps_difference_cents 440) [412,415,octpc_to_cps (5,2)] == [-114,-101,500]+--+-- > let abs_dif i j = abs (i - j)+-- > cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9+cps_difference_cents :: (Real r,Fractional r,Floating n) => r -> r -> n+cps_difference_cents p q = fratio_to_cents (q / p) +-- * Math/Ratio+ -- | Convert a (signed) number of octaves difference of given ratio to a ratio. -- -- > map (oct_diff_to_ratio 2) [-3 .. 3] == [1/8,1/4,1/2,1,2,4,8] -- > map (oct_diff_to_ratio (9/8)) [-3 .. 3] == [512/729,64/81,8/9,1/1,9/8,81/64,729/512] oct_diff_to_ratio :: Integral a => Ratio a -> Int -> Ratio a-oct_diff_to_ratio r n = if n >= 0 then recur_n n (* r) 1 else recur_n (negate n) (/ r) 1+oct_diff_to_ratio r n = if n >= 0 then T.recur_n n (* r) 1 else T.recur_n (negate n) (/ r) 1 --- | Lookup function that allows both negative & multiple octave indices.+-- | 'ratio_to_cents' rounded to nearest multiple of 100, modulo 12. ----- > let map_zip f l = zip l (map f l)--- > map_zip (tn_ratios_lookup werckmeister_vi) [-24 .. 24]-tn_ratios_lookup :: Tuning -> Int -> Maybe Rational-tn_ratios_lookup t n =-    let (o,pc) = n `divMod` tn_divisions t-        o_ratio = oct_diff_to_ratio (tn_octave_ratio t) o-    in fmap (\r -> o_ratio * (r !! pc)) (tn_ratios t)+-- > map (ratio_to_pc 0) [1,4/3,3/2,2] == [0,5,7,0]+ratio_to_pc :: Int -> Rational -> Int+ratio_to_pc n = T.mod12 . (+ n) . round . (/ 100) . ratio_to_cents --- | Lookup function that allows both negative & multiple octave indices.+-- | Fold ratio to lie within an octave, ie. @1@ '<' /n/ '<=' @2@.+--   It is an error for /n/ to be more than one octave outside of this range. ----- > map_zip (tn_approximate_ratios_lookup werckmeister_v) [-24 .. 24]-tn_approximate_ratios_lookup :: Tuning -> Int -> Approximate_Ratio-tn_approximate_ratios_lookup t n =-    let (o,pc) = n `divMod` tn_divisions t-        o_ratio = fromRational (oct_diff_to_ratio (tn_octave_ratio t) o)-    in o_ratio * ((tn_approximate_ratios t) !! pc)+-- > map fold_ratio_to_octave_nonrec [2/3,3/4,4/5,4/7] == [4/3,3/2,8/5,8/7]+fold_ratio_to_octave_nonrec :: (Ord n,Fractional n) => n -> n+fold_ratio_to_octave_nonrec n =+  if n >= 1 && n < 2+  then n+  else if n >= 2 && n < 4+       then n / 2+       else if n < 1 && n >= (1/2)+            then n * 2+            else error "fold_ratio_to_octave_nonrec" --- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents'--- of 'Tuning'.+-- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@.+--   It is an error if /n/ is less than or equal to zero. ----- > :l Music.Theory.Tuning.Werckmeister--- > let r = [1,17/16,9/8,13/11,5/4,4/3,7/5,3/2,11/7,5/3,16/9,15/8]--- > tn_reconstructed_ratios 1e-2 werckmeister_iii == Just r-tn_reconstructed_ratios :: Double -> Tuning -> Maybe [Rational]-tn_reconstructed_ratios epsilon =-    fmap (map (reconstructed_ratio epsilon)) .-    T.fromRight .-    tn_ratios_or_cents+-- > map fold_ratio_to_octave_err [2/2,2/3,3/4,4/5,4/7] == [1/1,4/3,3/2,8/5,8/7]+fold_ratio_to_octave_err :: (Ord n,Fractional n) => n -> n+fold_ratio_to_octave_err =+  let f n =+        if n <= 0+        then error "fold_ratio_to_octave_err?"+        else if n >= 2 then f (n / 2) else if n < 1 then f (n * 2) else n+  in f --- | Convert from a 'Floating' ratio to /cents/.+-- | In /n/ is greater than zero, 'fold_ratio_to_octave_err', else 'Nothing'. ----- > 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+-- > map fold_ratio_to_octave [0,1] == [Nothing,Just 1]+fold_ratio_to_octave :: (Ord n,Fractional n) => n -> Maybe n+fold_ratio_to_octave n = if n <= 0 then Nothing else Just (fold_ratio_to_octave_err n) --- | Type specialised 'fratio_to_cents'.-approximate_ratio_to_cents :: Approximate_Ratio -> Cents-approximate_ratio_to_cents = fratio_to_cents+-- | 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/ and select the minima at the /cmp_f/.+--+-- > map (ratio_interval_class_by id) [3/2,5/4] == [4/3,5/4]+ratio_interval_class_by :: (Ord t, Integral i) => (Ratio i -> t) -> Ratio i -> Ratio i+ratio_interval_class_by cmp_f i =+    let f = fold_ratio_to_octave_err+    in T.min_by cmp_f (f i) (f (recip i)) +-- | 'ratio_interval_class_by' 'ratio_nd_sum'+--+-- > map ratio_interval_class [2/3,3/2,3/4,4/3] == [3/2,3/2,3/2,3/2]+-- > map ratio_interval_class [7/6,12/7] == [7/6,7/6]+ratio_interval_class :: Integral i => Ratio i -> Ratio i+ratio_interval_class = ratio_interval_class_by T.ratio_nd_sum++-- * Types++-- | An approximation of a ratio.+type Approximate_Ratio = Double+ -- | Type specialised 'fromRational'. approximate_ratio :: Rational -> Approximate_Ratio approximate_ratio = fromRational +-- | A real valued division of a semi-tone into one hundred parts, and+-- hence of the octave into @1200@ parts.+type Cents = Double++-- | Integral cents value.+type Cents_I = Int++-- | Type specialised 'fratio_to_cents'.+approximate_ratio_to_cents :: Approximate_Ratio -> Cents+approximate_ratio_to_cents = fratio_to_cents+ -- | 'approximate_ratio_to_cents' '.' 'approximate_ratio'. --+-- > import Data.Ratio {- base -} -- > map (\n -> (n,round (ratio_to_cents (fold_ratio_to_octave_err (n % 1))))) [1..21] ratio_to_cents :: Integral i => Ratio i -> Cents ratio_to_cents = approximate_ratio_to_cents . realToFrac --- | Construct an exact 'Rational' that approximates 'Cents' to within--- /epsilon/.+-- | Construct an exact 'Rational' that approximates 'Cents' to within /epsilon/. ----- > map (reconstructed_ratio 1e-5) [0,700,1200] == [1,442/295,2]+-- > map (reconstructed_ratio 1e-5) [0,700,1200,1800] == [1,442/295,2,577/204] -- -- > ratio_to_cents (442/295) == 699.9976981706735 reconstructed_ratio :: Double -> Cents -> Rational-reconstructed_ratio epsilon c = approxRational (cents_to_ratio c) epsilon---- | Frequency /n/ cents from /f/.------ > import Music.Theory.Pitch--- > map (cps_shift_cents 440) [-100,100] == map octpc_to_cps [(4,8),(4,10)]-cps_shift_cents :: Floating a => a -> a -> a-cps_shift_cents f = (* f) . cents_to_ratio---- | Interval in /cents/ from /p/ to /q/, ie. 'ratio_to_cents' of /p/--- '/' /q/.------ > cps_difference_cents 440 (octpc_to_cps (5,2)) == 500------ > let abs_dif i j = abs (i - j)--- > in cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9-cps_difference_cents :: (Real r,Fractional r,Floating n) => r -> r -> n-cps_difference_cents p q = fratio_to_cents (q / p)+reconstructed_ratio epsilon c = approxRational (cents_to_fratio c) epsilon  -- * Commas @@ -192,174 +181,18 @@ mercators_comma :: Rational mercators_comma = 19383245667680019896796723 / 19342813113834066795298816 --- | Calculate /n/th root of /x/.------ > 12 `nth_root` 2 == twelve_tone_equal_temperament_comma-nth_root :: (Floating a,Eq a) => a -> a -> a-nth_root n x =-    let f (_,x0) = (x0, ((n-1)*x0+x/x0**(n-1))/n)-        e = uncurry (==)-    in fst (until e f (x, x/n))- -- | 12-tone equal temperament comma (ie. 12th root of 2). -- -- > twelve_tone_equal_temperament_comma == 1.0594630943592953 twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a-twelve_tone_equal_temperament_comma = 12 `nth_root` 2---- * Equal temperaments---- | Make /n/ division equal temperament.-equal_temperament :: Integral n => n -> Tuning-equal_temperament n =-    let c = genericTake n [0,1200 / fromIntegral n ..]-    in Tuning (Right c) 2---- | 12-tone equal temperament.------ > cents equal_temperament_12 == [0,100..1100]-equal_temperament_12 :: Tuning-equal_temperament_12 = equal_temperament (12::Int)---- | 19-tone equal temperament.-equal_temperament_19 :: Tuning-equal_temperament_19 = equal_temperament (19::Int)---- | 31-tone equal temperament.-equal_temperament_31 :: Tuning-equal_temperament_31 = equal_temperament (31::Int)---- | 53-tone equal temperament.-equal_temperament_53 :: Tuning-equal_temperament_53 = equal_temperament (53::Int)---- | 72-tone equal temperament.------ > let r = [0,17,33,50,67,83,100]--- > in take 7 (map round (cents equal_temperament_72)) == r-equal_temperament_72 :: Tuning-equal_temperament_72 = equal_temperament (72::Int)---- | 96-tone equal temperament.-equal_temperament_96 :: Tuning-equal_temperament_96 = equal_temperament (96::Int)---- * Harmonic series---- | Harmonic series to /n/th partial, with indicated octave.------ > harmonic_series 17 2-harmonic_series :: Integer -> Rational -> Tuning-harmonic_series n o = Tuning (Left [1 .. n%1]) o---- | Harmonic series on /n/.-harmonic_series_cps :: (Num t, Enum t) => t -> [t]-harmonic_series_cps n = [n,n * 2 ..]---- | /n/ elements of 'harmonic_series_cps'.------ > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935]--- > in harmonic_series_cps_n 17 55 == r-harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a]-harmonic_series_cps_n n = take n . harmonic_series_cps---- | Sub-harmonic series on /n/.-subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t]-subharmonic_series_cps n = map (* n) (map recip [1..])---- | /n/ elements of 'harmonic_series_cps'.------ > let r = [1760,880,587,440,352,293,251,220,196,176,160,147,135,126,117,110,104]--- > in map round (subharmonic_series_cps_n 17 1760) == r-subharmonic_series_cps_n :: (Fractional t,Enum t) => Int -> t -> [t]-subharmonic_series_cps_n n = take n . subharmonic_series_cps---- | /n/th partial of /f1/, ie. one indexed.------ > map (partial 55) [1,5,3] == [55,275,165]-partial :: (Num a, Enum a) => a -> Int -> a-partial f1 k = harmonic_series_cps f1 `at` (k - 1)--fold_ratio_to_octave' :: Integral i => Ratio i -> Ratio i-fold_ratio_to_octave' =-    let rec_f n = if n >= 2 then rec_f (n / 2) else if n < 1 then rec_f (n * 2) else n-    in rec_f---- | Error if input is less than or equal to zero.------ > map fold_ratio_to_octave_err [2/3,3/4] == [4/3,3/2]-fold_ratio_to_octave_err :: Integral i => Ratio i -> Ratio i-fold_ratio_to_octave_err n =-    if n <= 0-    then error "fold_ratio_to_octave"-    else fold_ratio_to_octave' n---- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@.------ > map fold_ratio_to_octave [0,1] == [Nothing,Just 1]-fold_ratio_to_octave :: Integral i => Ratio i -> Maybe (Ratio i)-fold_ratio_to_octave n = if n <= 0 then Nothing else Just (fold_ratio_to_octave' n)---- | Sun of numerator & denominator.-ratio_nd_sum :: Num a => Ratio a -> a-ratio_nd_sum r = numerator r + denominator r--min_by :: Ord a => (t -> a) -> t -> t -> t-min_by f p q = if f p <= f q then p else q---- | The interval between two pitches /p/ and /q/ given as ratio--- multipliers of a fundamental is /q/ '/' /p/.  The classes over such--- intervals consider the 'fold_ratio_to_octave' of both /p/ to /q/--- and /q/ to /p/.------ > map ratio_interval_class [2/3,3/2,3/4,4/3] == [3/2,3/2,3/2,3/2]--- > map ratio_interval_class [7/6,12/7] == [7/6,7/6]-ratio_interval_class :: Integral i => Ratio i -> Ratio i-ratio_interval_class i =-    let f = fold_ratio_to_octave_err-    in min_by ratio_nd_sum (f i) (f (recip i))---- | Derivative harmonic series, based on /k/th partial of /f1/.------ > import Music.Theory.Pitch------ > let {r = [52,103,155,206,258,309,361,412,464,515,567,618,670,721,773]--- >     ;d = harmonic_series_cps_derived 5 (octpc_to_cps (1,4))}--- > in map round (take 15 d) == r-harmonic_series_cps_derived :: (Ord a, Fractional a, Enum a) => Int -> a -> [a]-harmonic_series_cps_derived k f1 =-    let f0 = T.cps_in_octave_above f1 (partial f1 k)-    in harmonic_series_cps f0---- | Harmonic series to /n/th harmonic (folded, duplicated removed).------ > harmonic_series_folded_r 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8]------ > let r = [0,105,204,386,551,702,841,969,1088]--- > in map (round . ratio_to_cents) (harmonic_series_folded_r 17) == r-harmonic_series_folded_r :: Integer -> [Rational]-harmonic_series_folded_r n = nub (sort (map fold_ratio_to_octave_err [1 .. n%1]))---- | 'ratio_to_cents' variant of 'harmonic_series_folded'.-harmonic_series_folded_c :: Integer -> [Cents]-harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded_r--harmonic_series_folded :: Integer -> Rational -> Tuning-harmonic_series_folded n o = Tuning (Left (harmonic_series_folded_r n)) o---- | @12@-tone tuning of first @21@ elements of the harmonic series.------ > cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088]--- > divisions harmonic_series_folded_21 == 11-harmonic_series_folded_21 :: Tuning-harmonic_series_folded_21 = harmonic_series_folded 21 2+twelve_tone_equal_temperament_comma = 12 `T.nth_root` 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+-- > 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@@ -368,7 +201,7 @@ -- | Fractional form of 'cents_et12_diff'. fcents_et12_diff :: Real n => n -> n fcents_et12_diff n =-    let m = n `mod'` 100+    let m = n `Fixed.mod'` 100     in if m > 50 then m - 100 else m  -- | The class of cents intervals has range @(0,600)@.@@ -376,7 +209,7 @@ -- > 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+-- > map cents_interval_class [1200,1250 .. 2400] == r cents_interval_class :: Integral a => a -> a cents_interval_class n =     let n' = n `mod` 1200@@ -385,7 +218,7 @@ -- | Fractional form of 'cents_interval_class'. fcents_interval_class :: Real a => a -> a fcents_interval_class n =-    let n' = n `mod'` 1200+    let n' = n `Fixed.mod'` 1200     in if n' > 600 then 1200 - n' else n'  -- | Always include the sign, elide @0@.@@ -416,203 +249,34 @@ 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---- | Variant for tunings that are incomplete.-type Sparse_Midi_Tuning_F = Int -> Maybe T.Midi_Detune---- | Variant for sparse tunings that require state.-type Sparse_Midi_Tuning_ST_F st = st -> Int -> (st,Maybe T.Midi_Detune)---- | Lift 'Midi_Tuning_F' to 'Sparse_Midi_Tuning_F'.-lift_tuning_f :: Midi_Tuning_F -> Sparse_Midi_Tuning_F-lift_tuning_f tn_f = Just . tn_f---- | Lift 'Sparse_Midi_Tuning_F' to 'Sparse_Midi_Tuning_ST_F'.-lift_sparse_tuning_f :: Sparse_Midi_Tuning_F -> Sparse_Midi_Tuning_ST_F st-lift_sparse_tuning_f tn_f st k = (st,tn_f k)---- | (t,c,k) where t=tuning (must have 12 divisions of octave),--- c=cents deviation (ie. constant detune offset), k=midi offset--- (ie. value to be added to incoming midi note number).-type D12_Midi_Tuning = (Tuning,Cents,Int)---- | 'Midi_Tuning_F' for 'D12_Midi_Tuning'.------ > let f = d12_midi_tuning_f (equal_temperament 12,0,0)--- > map f [0..127] == zip [0..127] (repeat 0)-d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_F-d12_midi_tuning_f (t,c_diff,k) n =-    let (_,pc) = T.midi_to_octpc (n + k)-        dt = zipWith (-) (tn_cents t) [0,100 .. 1200]-    in if tn_divisions t /= 12-       then error "d12_midi_tuning_f: not d12"-       else case dt `atMay` pc of-              Nothing -> error "d12_midi_tuning_f: pc?"-              Just c -> (n,c + c_diff)---- | (t,f0,k,g) where t=tuning, f0=fundamental frequency, k=midi note--- number for f0, g=gamut-type CPS_Midi_Tuning = (Tuning,Double,Int,Int)---- | 'Midi_Tuning_F' for 'CPS_Midi_Tuning'.  The function is sparse, it is only--- valid for /g/ values from /k/.------ > let f = cps_midi_tuning_f (equal_temperament 72,T.midi_to_cps 59,59,72 * 4)--- > map f [59 .. 59 + 72]-cps_midi_tuning_f :: CPS_Midi_Tuning -> Sparse_Midi_Tuning_F-cps_midi_tuning_f (t,f0,k,g) n =-    let r = tn_approximate_ratios_cyclic t-        m = take g (map (T.cps_to_midi_detune . (* f0)) r)-    in m `atMay` (n - k)---- * Midi tuning tables.+-- * Savart --- | Midi-note-number -> CPS table, possibly sparse.-type MNN_CPS_Table = [(Int,Double)]+-- | Felix Savart (1791-1841), the ratio of 10:1 is assigned a value of 1000 savarts.+type Savarts = Double --- | Generates 'MNN_CPS_Table' given 'Midi_Tuning_F' with keys for all valid @MNN@.+-- | Ratio to savarts. ----- > import Sound.SC3.Plot--- > plot_p2_ln [map (fmap round) (gen_cps_tuning_tbl f)]-gen_cps_tuning_tbl :: Sparse_Midi_Tuning_F -> MNN_CPS_Table-gen_cps_tuning_tbl tn_f =-    let f n = case tn_f n of-                Just r -> Just (n,T.midi_detune_to_cps r)-                Nothing -> Nothing-    in mapMaybe f [0 .. 127]---- * Derived (secondary) tuning table (DTT) lookup.---- | Given an 'MNN_CPS_Table' /tbl/, a list of @CPS@ /c/, and a @MNN@ /m/--- find the @CPS@ in /c/ that is nearest to the @CPS@ in /t/ for /m/.-dtt_lookup :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (Maybe v,Maybe v)-dtt_lookup tbl cps n =-    let f = lookup n tbl-    in (f,fmap (T.find_nearest_err cps) f)---- | Require table be non-sparse.-dtt_lookup_err :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (k,v,v)-dtt_lookup_err tbl cps n =-    case dtt_lookup tbl cps n of-      (Just f,Just g) -> (n,f,g)-      _ -> error "dtt_lookup"---- | Given two tuning tables generate the @dtt@ table.-gen_dtt_lookup_tbl :: MNN_CPS_Table -> MNN_CPS_Table -> MNN_CPS_Table-gen_dtt_lookup_tbl t0 t1 =-    let ix = [0..127]-        cps = sort (map (T.p3_third . dtt_lookup_err t0 (map snd t1)) ix)-    in zip ix cps--gen_dtt_lookup_f :: MNN_CPS_Table -> MNN_CPS_Table -> Midi_Tuning_F-gen_dtt_lookup_f t0 t1 =-    let m = M.fromList (gen_dtt_lookup_tbl t0 t1)-    in T.cps_to_midi_detune . T.map_ix_err m---- * Euler-Fokker genus <http://www.huygens-fokker.org/microtonality/efg.html>---- | Normal form, value with occurences count (ie. exponent in notation above).-type EFG i = [(i,Int)]+-- > fratio_to_savarts 10 == 1000+-- > fratio_to_savarts 2 == 301.02999566398114+fratio_to_savarts :: Floating a => a -> a+fratio_to_savarts r = 1000 * logBase 10 r --- | Degree of EFG, ie. sum of exponents.+-- | Savarts to ratio. ----- > efg_degree [(3,3),(7,2)] == 3 + 2-efg_degree :: EFG i -> Int-efg_degree = sum . map snd+-- > savarts_to_fratio 1000 == 10+-- > savarts_to_fratio 301.02999566398118 == 2+savarts_to_fratio :: Floating a => a -> a+savarts_to_fratio s = 10 ** (s / 1000) --- | Number of tones of EFG, ie. product of increment of exponents.+-- | Savarts to cents. ----- > efg_tones [(3,3),(7,2)] == (3 + 1) * (2 + 1)-efg_tones :: EFG i -> Int-efg_tones = product . map ((+ 1) . snd)+-- > savarts_to_cents 1 == 3.9863137138648352+savarts_to_cents :: Floating a => a -> a+savarts_to_cents s = s * (6 / (5 * logBase 10 2)) --- | Collate a genus given as a multiset into standard form, ie. histogram.+-- | Cents to savarts. ----- > efg_collate [3,3,3,7,7] == [(3,3),(7,2)]-efg_collate :: Ord i => [i] -> EFG i-efg_collate = T.histogram . sort--{- | Factors of EFG given with co-ordinate of grid location.--> efg_factors [(3,3)]--> let r = [([0,0],[]),([0,1],[7]),([0,2],[7,7])->         ,([1,0],[3]),([1,1],[3,7]),([1,2],[3,7,7])->         ,([2,0],[3,3]),([2,1],[3,3,7]),([2,2],[3,3,7,7])->         ,([3,0],[3,3,3]),([3,1],[3,3,3,7]),([3,2],[3,3,3,7,7])]-> in efg_factors [(3,3),(7,2)] == r---}-efg_factors :: EFG i -> [([Int],[i])]-efg_factors efg =-    let k = map (\(_,n) -> [0 .. n]) efg-        k' = if length efg == 1-             then concatMap (map return) k-             else T.nfold_cartesian_product k-        z = map fst efg-        f ix = (ix,concat (zipWith (\n m -> replicate n (z !! m)) ix [0..]))-    in map f k'--{- | Ratios of EFG, taking /n/ as the 1:1 ratio, with indices, folded into one octave.--> let r = sort $ map snd $ efg_ratios 7 [(3,3),(7,2)]-> r == [1/1,9/8,8/7,9/7,21/16,189/128,3/2,27/16,12/7,7/4,27/14,63/32]-> map (round . ratio_to_cents) r == [0,204,231,435,471,675,702,906,933,969,1137,1173]--      0:         1/1          C          0.000 cents-      1:         9/8          D        203.910 cents-      2:         8/7          D+       231.174 cents-      3:         9/7          E+       435.084 cents-      4:        21/16         F-       470.781 cents-      5:       189/128        G-       674.691 cents-      6:         3/2          G        701.955 cents-      7:        27/16         A        905.865 cents-      8:        12/7          A+       933.129 cents-      9:         7/4          Bb-      968.826 cents-     10:        27/14         B+      1137.039 cents-     11:        63/32         C-      1172.736 cents-     12:         2/1          C       1200.000 cents--> let r' = sort $ map snd $ efg_ratios 5 [(5,2),(7,3)]-> r' == [1/1,343/320,35/32,49/40,5/4,343/256,7/5,49/32,8/5,1715/1024,7/4,245/128]-> map (round . ratio_to_cents) r' == [0,120,155,351,386,506,583,738,814,893,969,1124]--> let r'' = sort $ map snd $ efg_ratios 3 [(3,1),(5,1),(7,1)]-> r'' == [1/1,35/32,7/6,5/4,4/3,35/24,5/3,7/4]-> map (round . ratio_to_cents) r'' == [0,155,267,386,498,653,884,969]--> let c0 = [0,204,231,435,471,675,702,906,933,969,1137,1173,1200]-> let c1 = [0,120,155,351,386,506,583,738,814,893,969,1124,1200]-> let c2 = [0,155,267,386,498,653,884,969,1200]-> let f (c',y) = map (\x -> (x,y,x,y + 10)) c'-> map f (zip [c0,c1,c2] [0,20,40])---}-efg_ratios :: Real r => Rational -> EFG r -> [([Int],Rational)]-efg_ratios n =-    let to_r = fold_ratio_to_octave_err . (/ n) . toRational . product-        f (ix,i) = (ix,to_r i)-    in map f . efg_factors--{- | Generate a line drawing, as a set of (x0,y0,x1,y1) 4-tuples.-     h=row height, m=distance of vertical mark from row edge, k=distance between rows--> let e = [[3,3,3],[3,3,5],[3,5,5],[3,5,7],[3,7,7],[5,5,5],[5,5,7],[3,3,7],[5,7,7],[7,7,7]]-> let e = [[3,3,3],[5,5,5],[7,7,7],[3,3,5],[3,5,5],[5,5,7],[5,7,7],[3,7,7],[3,3,7],[3,5,7]]-> let e' = map efg_collate e-> efg_diagram_set (round,25,4,75) e'---}-efg_diagram_set :: (Enum n,Real n) => (Cents -> n,n,n,n) -> [EFG n] -> [(n,n,n,n)]-efg_diagram_set (to_f,h,m,k) e =-    let f = (++ [1200]) . sort . map (to_f . ratio_to_cents . snd) . efg_ratios 1-        g (c,y) = let y' = y + h-                      b = [(0,y,1200,y),(0,y',1200,y')]-                  in b ++ map (\x -> (x,y + m,x,y' - m)) c-    in concatMap g (zip (map f e) [0,k ..])+-- > cents_to_savarts 3.9863137138648352 == 1+-- > cents_to_savarts 1200 == ratio_to_savarts 2+cents_to_savarts :: Floating a => a -> a+cents_to_savarts c = c / (6 / (5 * logBase 10 2))
Music/Theory/Tuning/Alves_1997.hs view
@@ -3,54 +3,58 @@ -- 1997.  <http://www2.hmc.edu/~alves/pleng.html> module Music.Theory.Tuning.Alves_1997 where -import Music.Theory.Tuning+import Music.Theory.Tuning.Type {- hmt -} +-- > import Music.Theory.Tuning {- hmt -} -- > let c = [0,231,498,765,996]--- > in map (round.to_cents_r) alves_slendro_r == c+-- > map (round . ratio_to_cents) alves_slendro_r == c alves_slendro_r :: [Rational] alves_slendro_r = [1,8/7,4/3,14/9,16/9] --- | HMC /slendro/ tuning.------ > cents_i alves_slendro == [0,231,498,765,996]------ > scl <- scl_load "slendro_alves"--- > cents_i (scale_tuning 0.01 scl) == cents_i alves_slendro+{- | HMC /slendro/ tuning.++> cents_i alves_slendro == [0,231,498,765,996]++> import Music.Theory.Tuning.Scala {- hmt -}+> scl <- scl_load "alves_slendro"+> tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i alves_slendro+-} alves_slendro :: Tuning-alves_slendro = Tuning (Left alves_slendro_r) 2+alves_slendro = Tuning (Left alves_slendro_r) Nothing  -- > let c = [0,231,316,702,814]--- > in map (round.to_cents_r) alves_pelog_bem_r == c+-- > map (round . ratio_to_cents) alves_pelog_bem_r == c alves_pelog_bem_r :: [Rational] alves_pelog_bem_r = [1,8/7,6/5,3/2,8/5] --- | HMC /pelog bem/ tuning.------ > cents_i alves_pelog_bem == [0,231,316,702,814]------ > scl <- scl_load "pelog_alves"--- > cents_i (scale_tuning 0.01 scl) == [0,231,316,471,702,814,969]+{- | HMC /pelog bem/ tuning.++> tn_cents_i alves_pelog_bem == [0,231,316,702,814]++> scl <- scl_load "alves_pelog"+> tn_cents_i (scale_to_tuning 0.01 scl) == [0,231,316,471,702,814,969]+-} alves_pelog_bem :: Tuning-alves_pelog_bem = Tuning (Left alves_pelog_bem_r) 2+alves_pelog_bem = Tuning (Left alves_pelog_bem_r) Nothing  -- > let c = [0,386,471,857,969]--- > in map (round.to_cents_r) alves_pelog_barang_r == c+-- > map (round . ratio_to_cents) alves_pelog_barang_r == c alves_pelog_barang_r :: [Rational] alves_pelog_barang_r = [1,5/4,21/16,105/64,7/4]  -- | HMC /pelog barang/ tuning. ----- > cents_i alves_pelog_barang == [0,386,471,857,969]+-- > tn_cents_i alves_pelog_barang == [0,386,471,857,969] alves_pelog_barang :: Tuning-alves_pelog_barang = Tuning (Left alves_pelog_barang_r) 2+alves_pelog_barang = Tuning (Left alves_pelog_barang_r) Nothing  -- > let c = [0,386,471,702,969]--- > in map (round.to_cents_r) alves_pelog_23467 == c+-- > map (round . ratio_to_cents) alves_pelog_23467_r == c alves_pelog_23467_r :: [Rational] alves_pelog_23467_r = [1,5/4,21/16,3/2,7/4]  -- | HMC /pelog 2,3,4,6,7/ tuning. ----- > cents_i alves_pelog_23467 == [0,386,471,702,969]+-- > tn_cents_i alves_pelog_23467 == [0,386,471,702,969] alves_pelog_23467 :: Tuning-alves_pelog_23467 = Tuning (Left alves_pelog_23467_r) 2+alves_pelog_23467 = Tuning (Left alves_pelog_23467_r) Nothing
Music/Theory/Tuning/DB.hs view
@@ -3,7 +3,7 @@  import Data.List {- base -} -import Music.Theory.Tuning+import Music.Theory.Tuning.Type  import Music.Theory.Tuning.Alves_1997 import Music.Theory.Tuning.Gann_1993@@ -25,38 +25,50 @@ tuning_db :: [Named_Tuning] tuning_db =     [("Aaron","Pietro","","1523",pietro_aaron_1523,"meanquar")-    ,("Alves","Bill","Slendro","",alves_slendro,"slendro_alves")-    ,("Alves","Bill","Pelog/Bem","",alves_pelog_bem,"")-    ,("Alves","Bill","Pelog/Barang","",alves_pelog_barang,"")+    ,("Alves","Bill","Slendro","",alves_slendro,"slendro_alves") -- slendro9+    ,("Alves","Bill","Pelog/Bem","",alves_pelog_bem,"") -- hirajoshi2 / pelog_jc+    ,("Alves","Bill","Pelog/Barang","",alves_pelog_barang,"") -- surupan_degung / degung3     ,("Gann","Kyle","Superparticular","1992",gann_superparticular,"gann_super")-    ,("Harrison","Lou","Ditone","",harrison_ditone,"")+    ,("Harrison","Lou","Ditone","",harrison_ditone,"") -- pyth_12 / zwolle     ,("Harrison","Lou","16-tone","",lou_harrison_16,"harrison_16")-    ,("Johnston","Ben","MTP","1977",ben_johnston_mtp_1977,"")+    ,("Johnston","Ben","MTP","1977",ben_johnston_mtp_1977,"") -- carlos_harm     ,("Johnston","Ben","25-tone","",ben_johnston_25,"johnston_25")     ,("Kirnberger","Johann Philipp","III","",kirnberger_iii,"kirnberger")-    ,("Malcolm","Alexander","Monochord","1721",five_limit_tuning,"malcolm")+    ,("Malcolm","Alexander","Monochord","1721",five_limit_tuning,"malcolm") -- wurschmidt     ,("Partch","Harry","43-tone","",partch_43,"partch_43")-    ,("Polansky","Larry","Piano Study #5","1985",ps5_jpr,"polansky_ps")-    ,("Polansky","Larry","Psaltery","1978",psaltery_o,"")+    ,("Polansky","Larry","Piano Study #5","1985",ps5_jpr,"polansky_ps") -- 56-any+    ,("Polansky","Larry","Psaltery","1978",psaltery_o,"") -- dconv9marv     ,("Riley","Terry","Harp of New Albion","",riley_albion,"riley_albion")     ,("Tsuda","Mayumi","13-limit","",mayumi_tsuda,"tsuda13")-    ,("Vallotti","","","1754",vallotti,"vallotti")+    ,("Vallotti","","","1754",vallotti,"vallotti") -- bemetzrieder2     ,("Werckmeister","Andreas","Werckmeister III","",werckmeister_iii,"werck3")     ,("Werckmeister","Andreas","Werckmeister IV","",werckmeister_iv,"werck4")-    ,("Werckmeister","Andreas","Werckmeister V","",werckmeister_v,"werck5")+    ,("Werckmeister","Andreas","Werckmeister V","",werckmeister_v,"werck5") -- ammerbach1     ,("Werckmeister","Andreas","Werckmeister VI","",werckmeister_vi,"werck6")     ,("Young","La Monte","The Well-Tuned Piano","",lmy_wtp,"young-lm_piano")-    ,("Young","Thomas","","1799",thomas_young_1799,"young2")-    ,("Zarlino","Gioseffo","","1588",zarlino_1588,"zarlino2")+    ,("Young","Thomas","","1799",thomas_young_1799,"young1") -- young2+    ,("Zarlino","Gioseffo","","1588",zarlino_1588,"zarlino2") -- mersen_s3     ,("","","JI/12 7-limit","",septimal_tritone_just_intonation,"ji_12")-    ,("","","ET/12","",equal_temperament_12,"")-    ,("","","ET/19","",equal_temperament_19,"")-    ,("","","ET/31","",equal_temperament_31,"")-    ,("","","ET/53","",equal_temperament_53,"")-    ,("","","ET/72","",equal_temperament_72,"")-    ,("","","ET/96","",equal_temperament_96,"")-    ,("","","Pythagorean/12","",pythagorean_12,"pyth_12")+    ,("","","ET/12","",tn_equal_temperament_12,"et12")+    ,("","","ET/19","",tn_equal_temperament_19,"et19")+    ,("","","ET/31","",tn_equal_temperament_31,"et13")+    ,("","","ET/53","",tn_equal_temperament_53,"et53")+    ,("","","ET/72","",tn_equal_temperament_72,"et72")+    ,("","","ET/96","",tn_equal_temperament_96,"et96")+    ,("","","Pythagorean/12","",pythagorean_12,"pyth_12") -- zwolle     ]  tuning_db_lookup_scl :: String -> Maybe Tuning tuning_db_lookup_scl nm = fmap named_tuning_t (find (\(_,_,_,_,_,scl) -> scl == nm) tuning_db)++{-++import Music.Theory.Tuning.Scala+db <- scl_load_db+f n = take n . scl_db_query_cdiff_asc round db . sort . tn_cents_octave+f 2 pietro_aaron_1523+pp = mapM_ (putStrLn . unlines . scale_stat . snd)+mapM_ pp (map (f 2 . named_tuning_t) tuning_db)++-}+
Music/Theory/Tuning/DB/Alves.hs view
@@ -1,12 +1,17 @@ -- | Bill Alves. module Music.Theory.Tuning.DB.Alves where -import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- 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+{- | Ratios for 'harrison_ditone' (SCALA=pyth_12)++> import Music.Theory.Tuning {- hmt -}+> let c = [0,114,204,294,408,498,612,702,816,906,996,1110]+> map (round . ratio_to_cents) harrison_ditone_r == c++> import Music.Theory.Tuning.Scala {- hmt -}+> scl_find_ji (harrison_ditone_r ++ [2])+-} harrison_ditone_r :: [Rational] harrison_ditone_r =     [1,2187/2048 {- 256/243 -}@@ -17,10 +22,9 @@     ,27/16,16/9     ,243/128] --- | Ditone/pythagorean tuning,--- see <http://www.billalves.com/porgitaro/ditonesettuning.html>+-- | Ditone/pythagorean tuning, <http://www.billalves.com/porgitaro/ditonesettuning.html> -- -- > tn_divisions harrison_ditone == 12 -- > tn_cents_i harrison_ditone == [0,114,204,294,408,498,612,702,816,906,996,1110] harrison_ditone :: Tuning-harrison_ditone = Tuning (Left harrison_ditone_r) 2+harrison_ditone = Tuning (Left harrison_ditone_r) Nothing
Music/Theory/Tuning/DB/Gann.hs view
@@ -2,40 +2,41 @@ module Music.Theory.Tuning.DB.Gann where  import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}  -- * Historical  -- | Cents for 'pietro_aaron_1523'. -- -- > let c = [0,76,193,310,386,503,580,697,773,890,1007,1083]--- > in map round pietro_aaron_1523_c == c+-- > map round pietro_aaron_1523_c == c -- -- > map ((+ 60) . (/ 100)) pietro_aaron_1523_c pietro_aaron_1523_c :: [Cents] pietro_aaron_1523_c =     [0,76.0     ,193.2,310.3-    ,386.3+    ,386.3 -- 5/4     ,503.4,579.5-    ,696.8,772.6+    ,696.8,772.6 -- 25/16     ,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]+-- > tn_cents_i pietro_aaron_1523 == [0,76,193,310,386,503,580,697,773,890,1007,1083] -- -- > import Music.Theory.Tuning.Scala -- > scl <- scl_load "meanquar"--- > cents_i (scale_tuning 0.01 scl) == [0,76,193,310,386,503,579,697,773,890,1007,1083]+-- > tn_cents_i (scale_to_tuning 0.01 scl) == [0,76,193,310,386,503,579,697,773,890,1007,1083] pietro_aaron_1523 :: Tuning-pietro_aaron_1523 = Tuning (Right pietro_aaron_1523_c) 2+pietro_aaron_1523 = Tuning (Right pietro_aaron_1523_c) Nothing  -- | 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+-- > map round thomas_young_1799_c == c thomas_young_1799_c :: [Cents] thomas_young_1799_c =     [0,93.9@@ -48,12 +49,12 @@  -- | 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]+-- > tn_cents_i thomas_young_1799 == [0,94,196,298,392,500,592,698,796,894,1000,1092] -- -- > scl <- scl_load "young2"--- > cents_i (scale_tuning 0.01 scl) == cents_i thomas_young_1799+-- > tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i thomas_young_1799 thomas_young_1799 :: Tuning-thomas_young_1799 = Tuning (Right thomas_young_1799_c) 2+thomas_young_1799 = Tuning (Right thomas_young_1799_c) Nothing  -- | Ratios for 'zarlino'. --@@ -63,20 +64,20 @@  -- | Gioseffo Zarlino, 1588, see <http://www.kylegann.com/tuning.html>. ----- > divisions zarlino_1588 == 16--- > cents_i zarlino_1588 == [0,71,182,204,294,316,386,498,569,590,702,773,884,996,1018,1088]+-- > tn_divisions zarlino_1588 == 16+-- > tn_cents_i zarlino_1588 == [0,71,182,204,294,316,386,498,569,590,702,773,884,996,1018,1088] -- -- > scl <- scl_load "zarlino2"--- > cents_i (scale_tuning 0.01 scl) == cents_i zarlino_1588+-- > tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i zarlino_1588 zarlino_1588 :: Tuning-zarlino_1588 = Tuning (Left zarlino_1588_r) 2+zarlino_1588 = Tuning (Left zarlino_1588_r) Nothing  -- * 20th Century  -- | Ratios for 'ben_johnston_mtp_1977'. -- -- > let c = [0,105,204,298,386,471,551,702,841,906,969,1088]--- > in map (round . ratio_to_cents) ben_johnston_mtp_1977_r == c+-- > map (round . ratio_to_cents) ben_johnston_mtp_1977_r == c ben_johnston_mtp_1977_r :: [Rational] ben_johnston_mtp_1977_r =     [1,17/16@@ -90,9 +91,9 @@ -- | Ben Johnston's \"Suite for Microtonal Piano\" (1977), see -- <http://www.kylegann.com/tuning.html> ----- > cents_i ben_johnston_mtp_1977 == [0,105,204,298,386,471,551,702,841,906,969,1088]+-- > tn_cents_i ben_johnston_mtp_1977 == [0,105,204,298,386,471,551,702,841,906,969,1088] ben_johnston_mtp_1977 :: Tuning-ben_johnston_mtp_1977 = Tuning (Left ben_johnston_mtp_1977_r) 2+ben_johnston_mtp_1977 = Tuning (Left ben_johnston_mtp_1977_r) Nothing  -- * Gann @@ -105,9 +106,9 @@ -- | 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+-- > tn_cents_i gann_arcana_xvi == r gann_arcana_xvi :: Tuning-gann_arcana_xvi = Tuning (Left gann_arcana_xvi_r) 2+gann_arcana_xvi = Tuning (Left gann_arcana_xvi_r) Nothing  -- | Ratios for 'gann_superparticular'. gann_superparticular_r :: [Rational]@@ -118,13 +119,12 @@  -- | Kyle Gann, _Superparticular_, see <http://www.kylegann.com/Super.html>. ----- > divisions gann_superparticular == 22+-- > tn_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+-- > let r = [0,165,182,204,231,267,316,386,435,498,551,583,617,702,782,765,814,884,933,969,996,1018]+-- > tn_cents_i gann_superparticular == r -- -- > scl <- scl_load "gann_super"--- > cents_i (scale_tuning 0.01 scl) == cents_i gann_superparticular+-- > tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i gann_superparticular gann_superparticular :: Tuning-gann_superparticular = Tuning (Left gann_superparticular_r) 2+gann_superparticular = Tuning (Left gann_superparticular_r) Nothing
Music/Theory/Tuning/DB/Microtonal_Synthesis.hs view
@@ -2,6 +2,7 @@ module Music.Theory.Tuning.DB.Microtonal_Synthesis where  import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}  -- | Ratios for 'pythagorean'. pythagorean_12_r :: [Rational]@@ -21,7 +22,7 @@ -- > scl <- scl_load "pyth_12" -- > cents_i (scale_tuning 0.1 scl) == cents_i pythagorean_12 pythagorean_12 :: Tuning-pythagorean_12 = Tuning (Left pythagorean_12_r) 2+pythagorean_12 = Tuning (Left pythagorean_12_r) Nothing  -- | Ratios for 'five_limit_tuning'. --@@ -44,7 +45,7 @@ -- > scl <- scl_load "malcolm" -- > cents_i (scale_tuning 0.1 scl) == cents_i five_limit_tuning five_limit_tuning :: Tuning-five_limit_tuning = Tuning (Left five_limit_tuning_r) 2+five_limit_tuning = Tuning (Left five_limit_tuning_r) Nothing  -- | Ratios for 'septimal_tritone_just_intonation'. --@@ -69,7 +70,7 @@ -- > scl <- scl_load "ji_12" -- > cents_i (scale_tuning 0.1 scl) == cents_i septimal_tritone_just_intonation septimal_tritone_just_intonation :: Tuning-septimal_tritone_just_intonation = Tuning (Left septimal_tritone_just_intonation_r) 2+septimal_tritone_just_intonation = Tuning (Left septimal_tritone_just_intonation_r) Nothing  -- | Ratios for 'seven_limit_just_intonation'. --@@ -89,7 +90,7 @@ -- -- > 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+seven_limit_just_intonation = Tuning (Left seven_limit_just_intonation_r) Nothing  -- | Approximate ratios for 'kirnberger_iii'. --@@ -112,7 +113,7 @@ -- > scl <- scl_load "kirnberger" -- > cents_i (scale_tuning 0.1 scl) == cents_i kirnberger_iii kirnberger_iii :: Tuning-kirnberger_iii = Tuning (Right (map approximate_ratio_to_cents kirnberger_iii_ar)) 2+kirnberger_iii = Tuning (Right (map approximate_ratio_to_cents kirnberger_iii_ar)) Nothing  -- > let c = [0,94,196,298,392,502,592,698,796,894,1000,1090] -- > in map round vallotti_c == c@@ -134,7 +135,7 @@ -- > scl <- scl_load "vallotti" -- > cents_i (scale_tuning 0.1 scl) == cents_i vallotti vallotti :: Tuning-vallotti = Tuning (Right vallotti_c) 2+vallotti = Tuning (Right vallotti_c) Nothing  -- > let c = [0,128,139,359,454,563,637,746,841,911,1072,1183] -- > in map (round . ratio_to_cents) mayumi_tsuda == c@@ -156,7 +157,7 @@ -- > scl <- scl_load "tsuda13" -- > cents_i (scale_tuning 0.1 scl) == cents_i mayumi_tsuda mayumi_tsuda :: Tuning-mayumi_tsuda = Tuning (Left mayumi_tsuda_r) 2+mayumi_tsuda = Tuning (Left mayumi_tsuda_r) Nothing  -- | Ratios for 'lou_harrison_16'. --@@ -185,7 +186,7 @@ -- > scl <- scl_load "harrison_16" -- > cents_i (scale_tuning 0.1 scl) == cents_i lou_harrison_16 lou_harrison_16 :: Tuning-lou_harrison_16 = Tuning (Left lou_harrison_16_r) 2+lou_harrison_16 = Tuning (Left lou_harrison_16_r) Nothing  -- | Ratios for 'partch_43'. partch_43_r :: [Rational]@@ -210,7 +211,7 @@ -- > scl <- scl_load "partch_43" -- > cents_i (scale_tuning 0.1 scl) == cents_i partch_43 partch_43 :: Tuning-partch_43 = Tuning (Left partch_43_r) 2+partch_43 = Tuning (Left partch_43_r) Nothing  -- | Ratios for 'ben_johnston_25'. ben_johnston_25_r :: [Rational]@@ -227,4 +228,4 @@ -- > scl <- scl_load "johnston_25" -- > cents_i (scale_tuning 0.1 scl) == cents_i ben_johnston_25 ben_johnston_25 :: Tuning-ben_johnston_25 = Tuning (Left ben_johnston_25_r) 2+ben_johnston_25 = Tuning (Left ben_johnston_25_r) Nothing
Music/Theory/Tuning/DB/Riley.hs view
@@ -1,7 +1,7 @@ -- | Terry Riley. module Music.Theory.Tuning.DB.Riley where -import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}  -- | Ratios for 'riley_albion'. --@@ -19,4 +19,4 @@ -- > scl <- scl_load "riley_albion" -- > cents_i (scale_tuning 0.01 scl) == cents_i riley_albion riley_albion :: Tuning-riley_albion = Tuning (Left riley_albion_r) 2+riley_albion = Tuning (Left riley_albion_r) Nothing
Music/Theory/Tuning/DB/Werckmeister.hs view
@@ -2,6 +2,7 @@ module Music.Theory.Tuning.DB.Werckmeister where  import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}  -- | Approximate ratios for 'werckmeister_iii'. --@@ -32,7 +33,7 @@ -- > scl <- scl_load "werck3" -- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iii werckmeister_iii :: Tuning-werckmeister_iii = Tuning (Right werckmeister_iii_ar_c) 2+werckmeister_iii = Tuning (Right werckmeister_iii_ar_c) Nothing  -- | Approximate ratios for 'werckmeister_iv'. --@@ -61,7 +62,7 @@ -- > scl <- scl_load "werck4" -- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iv werckmeister_iv :: Tuning-werckmeister_iv = Tuning (Right werckmeister_iv_c) 2+werckmeister_iv = Tuning (Right werckmeister_iv_c) Nothing  -- | Approximate ratios for 'werckmeister_v'. --@@ -91,7 +92,7 @@ -- > scl <- scl_load "werck5" -- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_v werckmeister_v :: Tuning-werckmeister_v = Tuning (Right werckmeister_v_c) 2+werckmeister_v = Tuning (Right werckmeister_v_c) Nothing  -- | Ratios for 'werckmeister_vi', with supposed correction of 28/25 to 49/44. --@@ -114,4 +115,4 @@ -- > scl <- scl_load "werck6" -- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_vi werckmeister_vi :: Tuning-werckmeister_vi = Tuning (Left werckmeister_vi_r) 2+werckmeister_vi = Tuning (Left werckmeister_vi_r) Nothing
+ Music/Theory/Tuning/EFG.hs view
@@ -0,0 +1,111 @@+-- | Euler-Fokker genus <http://www.huygens-fokker.org/microtonality/efg.html>+module Music.Theory.Tuning.EFG where++import Data.List {- base -}++import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Set.List as T {- hmt -}++import Music.Theory.Tuning {- hmt -}++-- | Normal form, value with occurences count (ie. exponent in notation above).+type EFG i = [(i,Int)]++-- | Degree of EFG, ie. sum of exponents.+--+-- > efg_degree [(3,3),(7,2)] == 3 + 2+efg_degree :: EFG i -> Int+efg_degree = sum . map snd++-- | Number of tones of EFG, ie. product of increment of exponents.+--+-- > efg_tones [(3,3),(7,2)] == (3 + 1) * (2 + 1)+efg_tones :: EFG i -> Int+efg_tones = product . map ((+ 1) . snd)++-- | Collate a genus given as a multiset into standard form, ie. histogram.+--+-- > efg_collate [3,3,3,7,7] == [(3,3),(7,2)]+efg_collate :: Ord i => [i] -> EFG i+efg_collate = T.histogram . sort++{- | Factors of EFG given with co-ordinate of grid location.++> efg_factors [(3,3)]++> let r = [([0,0],[]),([0,1],[7]),([0,2],[7,7])+>         ,([1,0],[3]),([1,1],[3,7]),([1,2],[3,7,7])+>         ,([2,0],[3,3]),([2,1],[3,3,7]),([2,2],[3,3,7,7])+>         ,([3,0],[3,3,3]),([3,1],[3,3,3,7]),([3,2],[3,3,3,7,7])]++> efg_factors [(3,3),(7,2)] == r++-}+efg_factors :: EFG i -> [([Int],[i])]+efg_factors efg =+    let k = map (\(_,n) -> [0 .. n]) efg+        k' = if length efg == 1+             then concatMap (map return) k+             else T.nfold_cartesian_product k+        z = map fst efg+        f ix = (ix,concat (zipWith (\n m -> replicate n (z !! m)) ix [0..]))+    in map f k'++{- | Ratios of EFG, taking /n/ as the 1:1 ratio, with indices, folded into one octave.++> import Data.List+> let r = sort $ map snd $ efg_ratios 7 [(3,3),(7,2)]+> r == [1/1,9/8,8/7,9/7,21/16,189/128,3/2,27/16,12/7,7/4,27/14,63/32]+> map (round . ratio_to_cents) r == [0,204,231,435,471,675,702,906,933,969,1137,1173]++      0:         1/1          C          0.000 cents+      1:         9/8          D        203.910 cents+      2:         8/7          D+       231.174 cents+      3:         9/7          E+       435.084 cents+      4:        21/16         F-       470.781 cents+      5:       189/128        G-       674.691 cents+      6:         3/2          G        701.955 cents+      7:        27/16         A        905.865 cents+      8:        12/7          A+       933.129 cents+      9:         7/4          Bb-      968.826 cents+     10:        27/14         B+      1137.039 cents+     11:        63/32         C-      1172.736 cents+     12:         2/1          C       1200.000 cents++> let r' = sort $ map snd $ efg_ratios 5 [(5,2),(7,3)]+> r' == [1/1,343/320,35/32,49/40,5/4,343/256,7/5,49/32,8/5,1715/1024,7/4,245/128]+> map (round . ratio_to_cents) r' == [0,120,155,351,386,506,583,738,814,893,969,1124]++> let r'' = sort $ map snd $ efg_ratios 3 [(3,1),(5,1),(7,1)]+> r'' == [1/1,35/32,7/6,5/4,4/3,35/24,5/3,7/4]+> map (round . ratio_to_cents) r'' == [0,155,267,386,498,653,884,969]++> let c0 = [0,204,231,435,471,675,702,906,933,969,1137,1173,1200]+> let c1 = [0,120,155,351,386,506,583,738,814,893,969,1124,1200]+> let c2 = [0,155,267,386,498,653,884,969,1200]+> let f (c',y) = map (\x -> (x,y,x,y + 10)) c'+> map f (zip [c0,c1,c2] [0,20,40])++-}+efg_ratios :: Real r => Rational -> EFG r -> [([Int],Rational)]+efg_ratios n =+    let to_r = fold_ratio_to_octave_err . (/ n) . toRational . product+        f (ix,i) = (ix,to_r i)+    in map f . efg_factors++{- | Generate a line drawing, as a set of (x0,y0,x1,y1) 4-tuples.+     h=row height, m=distance of vertical mark from row edge, k=distance between rows++> let e = [[3,3,3],[3,3,5],[3,5,5],[3,5,7],[3,7,7],[5,5,5],[5,5,7],[3,3,7],[5,7,7],[7,7,7]]+> let e = [[3,3,3],[5,5,5],[7,7,7],[3,3,5],[3,5,5],[5,5,7],[5,7,7],[3,7,7],[3,3,7],[3,5,7]]+> let e' = map efg_collate e+> efg_diagram_set (round,25,4,75) e'++-}+efg_diagram_set :: (Enum n,Real n) => (Cents -> n,n,n,n) -> [EFG n] -> [(n,n,n,n)]+efg_diagram_set (to_f,h,m,k) e =+    let f = (++ [1200]) . sort . map (to_f . ratio_to_cents . snd) . efg_ratios 1+        g (c,y) = let y' = y + h+                      b = [(0,y,1200,y),(0,y',1200,y')]+                  in b ++ map (\x -> (x,y + m,x,y' - m)) c+    in concatMap g (zip (map f e) [0,k ..])
Music/Theory/Tuning/ET.hs view
@@ -47,7 +47,7 @@ -- | 'tbl_24et_f0' @440@. -- -- > length tbl_24et == 264--- > minmax (map (round . snd) tbl_24et) == (16,32535)+-- > T.minmax (map (round . snd) tbl_24et) == (16,32535) tbl_24et :: [(Pitch,Double)] tbl_24et = tbl_24et_f0 440 @@ -155,9 +155,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_R,Double)+pitch_72et :: (Midi,Int) -> (Pitch_R,Double) pitch_72et (x,n) =-    let p = midi_to_pitch pc_spell_ks x+    let p = midi_to_pitch_ks x         t = note p         a = alteration p         (t',n') = case a of
− Music/Theory/Tuning/Euler.hs 
@@ -1,138 +0,0 @@--- | Euler plane diagrams as /dot/ language graph.-module Music.Theory.Tuning.Euler where--import Data.List {- base -}-import Data.Ratio {- base -}--import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Math as T {- hmt -}-import qualified Music.Theory.Pitch.Note as T {- hmt -}-import qualified Music.Theory.Tuning as T {- hmt -}-import qualified Music.Theory.Tuple as T {- hmt -}---- | 'T.fold_ratio_to_octave' of '*'.-rat_mul :: Rational -> Rational -> Rational-rat_mul r = T.fold_ratio_to_octave_err . (* r)---- | 'T.fold_ratio_to_octave' of '/'.-rat_div :: Rational -> Rational -> Rational-rat_div p q = T.fold_ratio_to_octave_err (p / q)---- | /n/ = length, /m/ equals multiplier, /r/ = initial ratio.------ > tun_seq 5 (3/2) 1 == [1/1,3/2,9/8,27/16,81/64]-tun_seq :: Int -> Rational -> Rational -> [Rational]-tun_seq n m = take n . iterate (rat_mul m)--mod12 :: Integral a => a -> a-mod12 n = n `mod` 12---- | 'T.ratio_to_cents' rounded to nearest multiple of 100, modulo 12.------ > map (ratio_to_pc 0) [1,4/3,3/2,2] == [0,5,7,0]-ratio_to_pc :: Int -> Rational -> Int-ratio_to_pc n = mod12 . (+ n) . round . (/ 100) . T.ratio_to_cents--all_pairs :: [t] -> [u] -> [(t,u)]-all_pairs p q = [(x,y) | x <- p, y <- q]---- | Give all pairs from (l2,l1) and (l3,l2) that are at interval ratios r1 and r2 respectively.-euler_align_rat :: T.T2 Rational -> T.T3 [Rational] -> T.T2 [T.T2 Rational]-euler_align_rat (r1,r2) (l1,l2,l3) =-    let f r (p,q) = rat_mul p r == q-    in (filter (f r1) (all_pairs l2 l1)-       ,filter (f r2) (all_pairs l3 l2))---- | Pretty printer for pitch class.------ > unwords (map pc_pp [0..11]) == "C♮ C♯ D♮ E♭ E♮ F♮ F♯ G♮ A♭ A♮ B♭ B♮"-pc_pp :: (Integral i,Show i) => i -> String-pc_pp x =-    case T.pc_to_note_alteration_ks x of-      Just (n,a) -> [T.note_pp n,T.alteration_symbol a]-      Nothing -> error (show ("pc_pp",x))--cents_pp :: Rational -> String-cents_pp = show . (round :: Double -> Integer) . T.ratio_to_cents---- > rat_label (0,False) 1 == "C♮\\n1:1"--- > rat_label (3,True) (7/4) == "C♯=969\\n7:4"-rat_label :: (Int,Bool) -> Rational -> String-rat_label (k,with_cents) r =-    if r < 1 || r >= 2-    then error (show ("rat_label",r))-    else concat [pc_pp (ratio_to_pc k r)-                ,if with_cents-                 then '=' : cents_pp r-                 else ""-                ,"\\n",T.ratio_pp r]---- > rat_id (5/4) == "R_5_4"-rat_id :: Rational-> String-rat_id r = "R_" ++ show (numerator r) ++ "_" ++ show (denominator r)--rat_edge_label :: (Rational, Rational) -> String-rat_edge_label (p,q) = concat ["   (",T.ratio_pp (rat_div p q),")"]---- | Zip start-middle-end.------ > zip_sme (0,1,2) "abcd" == [(0,'a'),(1,'b'),(1,'c'),(2,'d')]-zip_sme :: (t,t,t) -> [u] -> [(t,u)]-zip_sme (s,m,e) xs =-    case xs of-      x0:x1:xs' -> (s,x0) : (m,x1) : T.at_last (\x -> (m,x)) (\x -> (e,x)) xs'-      _ -> error "zip_sme: not SME list"--type Euler_Plane t = ([[t]],[(t,t)])--euler_plane_to_dot :: (t -> String,t -> String,(t,t) -> String) -> Euler_Plane t -> [String]-euler_plane_to_dot (n_id,n_pp,e_pp) (h,v) =-    let mk_lab_term x =concat [" [label=\"",x,"\"];"]-        node_to_dot x = concat [n_id x,mk_lab_term (n_pp x)]-        subgraph_edges x = intercalate " -- " (map n_id x) ++ ";"-        edge_to_dot (lhs,rhs) = concat [n_id lhs," -- ",n_id rhs,mk_lab_term (e_pp (lhs,rhs))]-        subgraphs_to_dot (ty,x) = concat ["{rank=",ty,"; ",unwords (map n_id x),"}"]-    in ["graph g {"-       ,"graph [layout=\"dot\",rankdir=\"TB\",nodesep=0.5];"-       ,"edge [fontsize=\"8\",fontname=\"century schoolbook\"];"-       ,"node [shape=\"plaintext\",fontsize=\"10\",fontname=\"century schoolbook\"];"] ++-       map node_to_dot (concat h) ++-       map subgraph_edges h ++-       map edge_to_dot v ++-       map subgraphs_to_dot (zip_sme ("min","same","max") h) ++-       ["}"]--euler_plane_to_dot_rat :: (Int, Bool) -> Euler_Plane Rational -> [String]-euler_plane_to_dot_rat opt = euler_plane_to_dot (rat_id,rat_label opt,rat_edge_label)--{---let j5 =-    let {l1 = tun_seq 3 (3%2) (5%3)-        ;l2 = tun_seq 5 (3%2) (16%9)-        ;l3 = tun_seq 4 (3%2) (64%45)-        ;(c1,c2) = euler_align_rat (5%8,5%4) (l1,l2,l3)}-    in ([l1,l2,l3],c1 ++ c2)--let j5' =-    let {f = T.fold_ratio_to_octave_err-        ;l1 = tun_seq 4 (3/2) (f (1 * 2/3 * 5/4))-        ;l2 = tun_seq 5 (3/2) (f (1 * 2/3 * 2/3))-        ;l3 = tun_seq 3 (3/2) (f (1 * 2/3 * 4/5))-        ;(c1,c2) = euler_align_rat (5/4,5/4) (l1,l2,l3)}-    in ([l1,l2,l3],c1 ++ c2)--let j7 =-    let {l1 = tun_seq 4 (3%2) (5%4)-        ;l2 = tun_seq 5 (3%2) (4%3)-        ;l3 = tun_seq 3 (3%2) (14%9)-        ;(c1,c2) = euler_align_rat (5%4,4%7) (l1,l2,l3)}-    in ([l1,l2,l3],c1 ++ c2)--let dir = "/home/rohan/sw/hmt/data/dot/"-let f = unlines . euler_plane_to_dot_rat (0,False)-writeFile (dir ++ "euler-j5-a.dot") (f j5)-writeFile (dir ++ "euler-j5-b.dot") (f j5')-writeFile (dir ++ "euler-j7.dot") (f j7)---}
Music/Theory/Tuning/Gann_1993.hs view
@@ -6,9 +6,11 @@ import Data.Maybe {- base -}  import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Math as T {- hmt -} import qualified Music.Theory.Pitch as T {- hmt -} import qualified Music.Theory.Tuning as T {- hmt -}-import qualified Music.Theory.Tuning.Euler as T {- hmt -}+import qualified Music.Theory.Tuning.Graph.Euler as T {- hmt -}+import qualified Music.Theory.Tuning.Type as T {- hmt -}  {- | Ratios for 'lmy_wtp'. lmy = La Monte Young. wtp = Well-Tuned Piano. @@ -101,7 +103,7 @@  -} lmy_wtp :: T.Tuning-lmy_wtp = T.Tuning (Left lmy_wtp_r) 2+lmy_wtp = T.Tuning (Left lmy_wtp_r) Nothing  -- | Ratios for 'lmy_wtp_1964. lmy_wtp_1964_r :: [Rational]@@ -121,7 +123,7 @@  -} lmy_wtp_1964 :: T.Tuning-lmy_wtp_1964 = T.Tuning (Left lmy_wtp_1964_r) 2+lmy_wtp_1964 = T.Tuning (Left lmy_wtp_1964_r) Nothing  {- | Euler diagram for 'lmy_wtp'.
+ Music/Theory/Tuning/Graph/Euler.hs view
@@ -0,0 +1,124 @@+-- | Euler plane diagrams as /dot/ language graphs.+--+-- <http://rohandrape.net/?t=hmt-texts&e=md/euler.md>+module Music.Theory.Tuning.Graph.Euler where++import Data.List {- base -}+import Data.Ratio {- base -}++import qualified Music.Theory.Function as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Pitch.Note as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuple as T {- hmt -}++-- | 'T.fold_ratio_to_octave_err' of '*'.+rat_mul :: Rational -> Rational -> Rational+rat_mul r = T.fold_ratio_to_octave_err . (* r)++-- | 'T.fold_ratio_to_octave_err' of '/'.+rat_div :: Rational -> Rational -> Rational+rat_div p q = T.fold_ratio_to_octave_err (p / q)++-- | /n/ = length, /m/ = multiplier, /r/ = initial ratio.+--+-- > tun_seq 5 (3/2) 1 == [1/1,3/2,9/8,27/16,81/64]+tun_seq :: Int -> Rational -> Rational -> [Rational]+tun_seq n m = take n . iterate (rat_mul m)++-- | All possible pairs of elements (/x/,/y/) where /x/ is from /p/ and /y/ from /q/.+--+-- > all_pairs "ab" "cde" == [('a','c'),('a','d'),('a','e'),('b','c'),('b','d'),('b','e')]+all_pairs :: [t] -> [u] -> [(t,u)]+all_pairs p q = [(x,y) | x <- p, y <- q]++-- | Give all pairs from (l2,l1) and (l3,l2) that are at interval ratios r1 and r2 respectively.+euler_align_rat :: T.T2 Rational -> T.T3 [Rational] -> T.T2 [T.T2 Rational]+euler_align_rat (r1,r2) (l1,l2,l3) =+    let f r (p,q) = rat_mul p r == q+    in (filter (f r1) (all_pairs l2 l1)+       ,filter (f r2) (all_pairs l3 l2))++-- | Pretty printer for pitch class (UNICODE).+--+-- > unwords (map pc_pp [0..11]) == "C♮ C♯ D♮ E♭ E♮ F♮ F♯ G♮ A♭ A♮ B♭ B♮"+pc_pp :: (Integral i,Show i) => i -> String+pc_pp x =+    case T.pc_to_note_alteration_ks x of+      Just (n,a) -> [T.note_pp n,T.alteration_symbol a]+      Nothing -> error (show ("pc_pp",x))++-- | Show ratio as intergral ('round') cents value.+cents_pp :: Rational -> String+cents_pp = show . (round :: Double -> Integer) . T.ratio_to_cents++-- | (unit-pitch-class,print-cents)+type RAT_LABEL_OPT = (Int,Bool)++-- | Dot label for ratio, /k/ is the pitch-class of the unit ratio.+--+-- > rat_label (0,False) 1 == "C♮\\n1:1"+-- > rat_label (3,True) (7/4) == "C♯=969\\n7:4"+rat_label :: RAT_LABEL_OPT -> Rational -> String+rat_label (k,with_cents) r =+    if r < 1 || r >= 2+    then error (show ("rat_label",r))+    else concat [pc_pp (T.ratio_to_pc k r)+                ,if with_cents+                 then '=' : cents_pp r+                 else ""+                ,"\\n",T.ratio_pp r]++-- | Generate value /dot/ node identifier for ratio.+--+-- > rat_id (5/4) == "R_5_4"+rat_id :: Rational-> String+rat_id r = "R_" ++ show (numerator r) ++ "_" ++ show (denominator r)++-- | Printer for edge label between given ratio nodes.+rat_edge_label :: (Rational, Rational) -> String+rat_edge_label (p,q) = concat ["   (",T.ratio_pp (rat_div p q),")"]++-- | Zip start-middle-end.+--+-- > zip_sme (0,1,2) "abcd" == [(0,'a'),(1,'b'),(1,'c'),(2,'d')]+zip_sme :: (t,t,t) -> [u] -> [(t,u)]+zip_sme (s,m,e) xs =+    case xs of+      x0:x1:xs' -> (s,x0) : (m,x1) : T.at_last (\x -> (m,x)) (\x -> (e,x)) xs'+      _ -> error "zip_sme: not SME list"++-- | Euler diagram given as (/h/,/v/) duple,+-- where /h/ are the horizontal sequences and /v/ are the vertical edges.+type Euler_Plane t = ([[t]],[(t,t)])++-- | Ratios at plane, sorted.+euler_plane_r :: Ord t => Euler_Plane t -> [t]+euler_plane_r = sort . concat . fst++-- | Apply /f/ at all nodes of the plane.+euler_plane_map :: (t -> u) -> Euler_Plane t -> Euler_Plane u+euler_plane_map f (p,q) = (map (map f) p,map (T.bimap1 f) q)++-- | Generate /dot/ graph given printer functions and an /Euler_Plane/.+euler_plane_to_dot :: (t -> String,t -> String,(t,t) -> String) -> Euler_Plane t -> [String]+euler_plane_to_dot (n_id,n_pp,e_pp) (h,v) =+    let mk_lab_term x = concat [" [label=\"",x,"\"];"]+        node_to_dot x = concat [n_id x,mk_lab_term (n_pp x)]+        subgraph_edges x = intercalate " -- " (map n_id x) ++ ";"+        edge_to_dot (lhs,rhs) = concat [n_id lhs," -- ",n_id rhs,mk_lab_term (e_pp (lhs,rhs))]+        subgraphs_to_dot (ty,x) = concat ["{rank=",ty,"; ",unwords (map n_id x),"}"]+    in ["graph g {"+       ,"graph [layout=\"dot\",rankdir=\"TB\",nodesep=0.5];"+       ,"edge [fontsize=\"8\",fontname=\"century schoolbook\"];"+       ,"node [shape=\"plaintext\",fontsize=\"10\",fontname=\"century schoolbook\"];"] +++       map node_to_dot (concat h) +++       map subgraph_edges h +++       map edge_to_dot v +++       map subgraphs_to_dot (zip_sme ("min","same","max") h) +++       ["}"]++-- | Variant with default printers and fixed node type.+euler_plane_to_dot_rat :: RAT_LABEL_OPT -> Euler_Plane Rational -> [String]+euler_plane_to_dot_rat opt = euler_plane_to_dot (rat_id,rat_label opt,rat_edge_label)
+ Music/Theory/Tuning/Graph/ISET.hs view
@@ -0,0 +1,126 @@+-- | Tuning graph with edges determined by interval set.+module Music.Theory.Tuning.Graph.ISET where++import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Data.Graph.Inductive.Graph as FGL {- fgl -}+import qualified Data.Graph.Inductive.PatriciaTree as FGL {- fgl -}++import qualified Music.Theory.Graph.Dot as T {- hmt -}+import qualified Music.Theory.Graph.FGL as T {- hmt -}+import qualified Music.Theory.Graph.Type as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.Graph.Euler as Euler {- hmt -}+import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}++-- * R++-- | R = Rational+type R = Rational++-- | Flip a ratio in (1,2) and multiply by 2.+--+-- > import Data.Ratio {- base -}+-- > map r_flip [5%4,3%2,7%4] == [8%5,4%3,8%7]+-- > map r_flip [3/2,5/4,7/4] == [4/3,8/5,8/7]+r_flip :: R -> R+r_flip n = if n < 1 || n > 2 then error "r_flip" else 1 / n * 2++-- | r = ratio, nrm = normalise+r_nrm :: R -> R+r_nrm = T.ratio_interval_class_by id++-- | The folded interval from p to q.+--+-- > r_rel (1,3/2) == 4/3+r_rel :: (R,R) -> R+r_rel (p,q) = T.fold_ratio_to_octave_err (p / q)++-- | The interval set /i/ and it's 'r_flip'.+iset_sym :: [R] -> [R]+iset_sym l = l ++ map r_flip l++-- | Require r to have a perfect octave as last element, and remove it.+rem_oct :: [R] -> [R]+rem_oct r = if last r /= 2 then error "rem_oct" else T.drop_last r++r_pcset :: [R] -> [Int]+r_pcset = sort . map (T.ratio_to_pc 0)++r_pcset_univ :: [R] -> [Int]+r_pcset_univ = nub . r_pcset++-- | Does [R] construct indicated /pcset/.+r_is_pcset :: [Int] -> [R] -> Bool+r_is_pcset pcset = ((==) pcset) . r_pcset++-- * G++-- | Edges are (v1,v2) where v1 < v2+type G = T.GR R++edj_r :: (R, R) -> R+edj_r = r_nrm . r_rel++-- | The graph with vertices /scl_r/ and all edges where the interval (i,j) is in /iset/.+mk_graph :: [R] -> [R] -> G+mk_graph iset scl_r =+  (scl_r+  ,filter+    (\e -> edj_r e `elem` iset_sym iset)+    [(p,q) |+     p <- scl_r,+     q <- scl_r,+     p < q])++gen_graph :: Ord v => [T.DOT_META_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]+gen_graph opt pp es = T.fgl_to_udot opt pp (T.g_from_edges_l es)++g_to_dot :: Int -> [(String,String)] -> (R -> [(String,String)]) -> G -> [String]+g_to_dot k attr v_attr (_,e_set) =+  let opt =+        [("graph:layout","neato")+        ,("node:shape","plaintext")+        ,("node:fontsize","10")+        ,("node:fontname","century schoolbook")+        ,("edge:fontsize","9")]+  in gen_graph+     (opt ++ attr)+     (\(_,v) -> ("label",Euler.rat_label (k,True) v) : v_attr v+     ,\(_,e) -> [("label",T.rational_pp e)])+     (map (\e -> (e,edj_r e)) e_set)++-- * SCALA++mk_graph_scl :: [R] -> Scala.Scale -> G+mk_graph_scl iset = mk_graph iset . rem_oct . Scala.scale_ratios_req++scl_to_dot :: ([R], Int, [(String, String)], R -> [(String, String)]) -> String -> IO [String]+scl_to_dot (iset,k,attr,v_attr) nm = do+  sc <- Scala.scl_load nm+  let gr = mk_graph_scl iset sc+  return (g_to_dot k attr v_attr gr)++-- * FGL++graph_to_fgl :: G -> FGL.Gr R R+graph_to_fgl (v,e) =+  let fgl_v = zip [0..] v+      r_to_v :: R -> Int+      r_to_v x = fromJust (T.reverse_lookup x fgl_v)+      fgl_e = map (\(p,q) -> (r_to_v p,r_to_v q,edj_r (p,q))) e+  in FGL.mkGraph fgl_v fgl_e++mk_graph_fgl :: [R] -> [R] -> FGL.Gr R R+mk_graph_fgl iset = graph_to_fgl . mk_graph iset++{-+-- | List of nodes at /g/ connected to node /r/.+g_edge_list :: G -> R -> [R]+g_edge_list (_,e) r =+  let f (p,q) = if r == p then Just q else if r == q then Just p else Nothing+  in mapMaybe f e+-}
+ Music/Theory/Tuning/HS.hs view
@@ -0,0 +1,81 @@+-- | Harmonic series+module Music.Theory.Tuning.HS where++import Data.List {- base -}+import Data.Ratio {- base -}+import qualified Safe {- safe -}++import qualified Music.Theory.Pitch as T {- hmt -}+import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}+++-- | Harmonic series to /n/th partial, with indicated octave.+--+-- > harmonic_series 17 2+harmonic_series :: Integer -> Maybe Rational -> Tuning+harmonic_series n o = Tuning (Left [1 .. n%1]) (fmap Left o)++-- | Harmonic series on /n/.+harmonic_series_cps :: (Num t, Enum t) => t -> [t]+harmonic_series_cps n = [n,n * 2 ..]++-- | /n/ elements of 'harmonic_series_cps'.+--+-- > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935]+-- > 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]+-- > 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 `Safe.at` (k - 1)++-- | 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]+-- > let d = harmonic_series_cps_derived 5 (T.octpc_to_cps (1,4))+-- > map round (take 15 d) == r+harmonic_series_cps_derived :: (Ord a, RealFrac a, Floating a, Enum a) => Int -> a -> [a]+harmonic_series_cps_derived k f1 =+    let f0 = T.cps_in_octave_above f1 (partial f1 k)+    in harmonic_series_cps f0++-- | Harmonic series to /n/th harmonic (folded, duplicated removed).+--+-- > harmonic_series_folded_r 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8]+--+-- > let r = [0,105,204,386,551,702,841,969,1088]+-- > map (round . ratio_to_cents) (harmonic_series_folded_r 17) == r+harmonic_series_folded_r :: Integer -> [Rational]+harmonic_series_folded_r n = nub (sort (map fold_ratio_to_octave_err [1 .. n%1]))++-- | 'ratio_to_cents' variant of 'harmonic_series_folded'.+harmonic_series_folded_c :: Integer -> [Cents]+harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded_r++harmonic_series_folded :: Integer -> Tuning+harmonic_series_folded n = Tuning (Left (harmonic_series_folded_r n)) Nothing++-- | @12@-tone tuning of first @21@ elements of the harmonic series.+--+-- > tn_cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088]+-- > tn_divisions harmonic_series_folded_21 == 11+harmonic_series_folded_21 :: Tuning+harmonic_series_folded_21 = harmonic_series_folded 21+
Music/Theory/Tuning/Load.hs view
@@ -6,13 +6,15 @@ import qualified Music.Theory.Array.CSV as T import qualified Music.Theory.Pitch as T import qualified Music.Theory.Tuning as T+import qualified Music.Theory.Tuning.Midi as T import qualified Music.Theory.Tuning.Scala as T+import qualified Music.Theory.Tuning.Type as T  -- | Load possibly sparse and possibly one-to-many -- (midi-note-number,cps-frequency) table from CSV file. -- -- > load_cps_tbl "/home/rohan/dr.csv"-load_cps_tbl :: FilePath -> IO [(Int,Double)]+load_cps_tbl :: FilePath -> IO [(T.Midi,Double)] load_cps_tbl nm = do   tbl <- T.csv_table_read_def id nm   let f e = case e of@@ -22,22 +24,26 @@  -- | Load scala scl file as 'T.Tuning'. load_tuning_scl :: String -> IO T.Tuning-load_tuning_scl = fmap (T.scale_to_tuning 0.01) . T.scl_load+load_tuning_scl = fmap T.scale_to_tuning . T.scl_load +-- | cps = (tuning-name,frequency-zero,midi-note-number-of-f0)+--   d12 = (tuning-name,cents-deviation,midi-note-offset)+type LOAD_TUNING_OPT = (String,Double,T.Midi)+ -- | Load scala file and apply 'T.cps_midi_tuning_f'.-load_tuning_cps :: (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F+load_tuning_cps :: LOAD_TUNING_OPT -> IO T.Sparse_Midi_Tuning_F load_tuning_cps (nm,f0,k) =-    let f tn = T.cps_midi_tuning_f (tn,f0,k,128-k)+    let f tn = T.cps_midi_tuning_f (tn,f0,k,128 - T.midi_to_int k)     in fmap f (load_tuning_scl nm)  -- | Load scala file and apply 'T.d12_midi_tuning_f'.-load_tuning_d12 :: (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F+load_tuning_d12 :: LOAD_TUNING_OPT -> IO T.Sparse_Midi_Tuning_F load_tuning_d12 (nm,dt,k) =     let f tn = T.lift_tuning_f (T.d12_midi_tuning_f (tn,dt,k))     in fmap f (load_tuning_scl nm)  -- | Lookup first matching element in table.-load_tuning_tbl :: (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F+load_tuning_tbl :: LOAD_TUNING_OPT -> IO T.Sparse_Midi_Tuning_F load_tuning_tbl (nm,dt,k) =     let from_cps = T.cps_to_midi_detune . flip T.cps_shift_cents dt         f tbl mnn = fmap from_cps (lookup (mnn + k) tbl)@@ -52,7 +58,7 @@     in (l !! i,g')  -- | Load tuning table with stateful selection function for one-to-many entries.-load_tuning_tbl_st :: Choose_f st (Int,Double) -> (String,Double,Int) -> IO (T.Sparse_Midi_Tuning_ST_F st)+load_tuning_tbl_st :: Choose_f st (T.Midi,Double) -> LOAD_TUNING_OPT -> IO (T.Sparse_Midi_Tuning_ST_F st) load_tuning_tbl_st choose_f (nm,dt,k) =     let from_cps = T.cps_to_midi_detune . flip T.cps_shift_cents dt         f tbl g mnn = case filter ((== (mnn + k)) . fst) tbl of@@ -61,7 +67,7 @@                              in (g',Just (from_cps e))     in fmap f (load_cps_tbl nm) -load_tuning_ty :: String -> (String,Double,Int) -> IO T.Sparse_Midi_Tuning_F+load_tuning_ty :: String -> LOAD_TUNING_OPT -> IO T.Sparse_Midi_Tuning_F load_tuning_ty ty opt =     case ty of       "cps" -> load_tuning_cps opt@@ -69,7 +75,7 @@       "tbl" -> load_tuning_tbl opt       _ -> error "cps|d12|tbl" -load_tuning_st_ty :: String -> (String,Double,Int) -> IO (T.Sparse_Midi_Tuning_ST_F StdGen)+load_tuning_st_ty :: String -> LOAD_TUNING_OPT -> IO (T.Sparse_Midi_Tuning_ST_F StdGen) load_tuning_st_ty ty opt =     case ty of       "cps" -> fmap T.lift_sparse_tuning_f (load_tuning_cps opt)
Music/Theory/Tuning/Meyer_1929.hs view
@@ -95,13 +95,17 @@ degree :: Integral i => i -> i degree = genericLength . elements --- | <http://en.wikipedia.org/wiki/Farey_sequence>------ > let r = [[0,1/2,1]--- >         ,[0,1/3,1/2,2/3,1]--- >         ,[0,1/4,1/3,1/2,2/3,3/4,1]--- >         ,[0,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,1]--- >         ,[0,1/6,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,5/6,1]]--- > in map farey_sequence [2..6] == r+{- | <http://en.wikipedia.org/wiki/Farey_sequence>++> r = [[0                                              ]+>     ,[0                                            ,1]+>     ,[0                    ,1/2                    ,1]+>     ,[0            ,1/3    ,1/2    ,2/3            ,1]+>     ,[0        ,1/4,1/3    ,1/2    ,2/3,3/4        ,1]+>     ,[0    ,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5    ,1]+>     ,[0,1/6,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,5/6,1]]++> map farey_sequence [0..6]+-} farey_sequence :: Integral a => a -> [Ratio a] farey_sequence k = 0 : nub (sort [n%d | d <- [1..k], n <- [1..d]])
+ Music/Theory/Tuning/Midi.hs view
@@ -0,0 +1,129 @@+-- | Midi + Tuning+module Music.Theory.Tuning.Midi where++import Data.List {- base -}+import qualified Data.Map as M {- containers -}+import Data.Maybe {- base -}+import Data.Word {- base -}+import qualified Safe {- safe -}++import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Map as T {- hmt -}+import qualified Music.Theory.Pitch as T {- hmt -}+import qualified Music.Theory.Tuple as T {- hmt -}++import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}++-- | (/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 = T.Midi -> T.Midi_Detune++-- | Variant for tunings that are incomplete.+type Sparse_Midi_Tuning_F = T.Midi -> Maybe T.Midi_Detune++-- | Variant for sparse tunings that require state.+type Sparse_Midi_Tuning_ST_F st = st -> T.Midi -> (st,Maybe T.Midi_Detune)++-- | Lift 'Midi_Tuning_F' to 'Sparse_Midi_Tuning_F'.+lift_tuning_f :: Midi_Tuning_F -> Sparse_Midi_Tuning_F+lift_tuning_f tn_f = Just . tn_f++-- | Lift 'Sparse_Midi_Tuning_F' to 'Sparse_Midi_Tuning_ST_F'.+lift_sparse_tuning_f :: Sparse_Midi_Tuning_F -> Sparse_Midi_Tuning_ST_F st+lift_sparse_tuning_f tn_f st k = (st,tn_f k)++-- | (t,c,k) where+--   t=tuning (must have 12 divisions of octave),+--   c=cents deviation (ie. constant detune offset),+--   k=midi offset (ie. value to be added to incoming midi note number).+type D12_Midi_Tuning = (Tuning,Cents,T.Midi)++-- | 'Midi_Tuning_F' for 'D12_Midi_Tuning'.+--+-- > let f = d12_midi_tuning_f (equal_temperament 12,0,0)+-- > map f [0..127] == zip [0..127] (repeat 0)+d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_F+d12_midi_tuning_f (t,c_diff,k) n =+    let (_,pc) = T.midi_to_octpc (n + k)+        dt = zipWith (-) (tn_cents t) [0,100 .. 1200]+    in if tn_divisions t /= 12+       then error "d12_midi_tuning_f: not d12"+       else case dt `Safe.atMay` pc of+              Nothing -> error "d12_midi_tuning_f: pc?"+              Just c -> (n,c + c_diff)++-- | (t,f0,k,g) where+--   t=tuning, f0=fundamental-frequency, k=midi-note-number (for f0), g=gamut+type CPS_Midi_Tuning = (Tuning,Double,T.Midi,Int)++-- | 'Midi_Tuning_F' for 'CPS_Midi_Tuning'.  The function is sparse, it is only+-- valid for /g/ values from /k/.+--+-- > import qualified Music.Theory.Pitch as T+-- > let f = cps_midi_tuning_f (equal_temperament 72,T.midi_to_cps 59,59,72 * 4)+-- > map f [59 .. 59 + 72]+cps_midi_tuning_f :: CPS_Midi_Tuning -> Sparse_Midi_Tuning_F+cps_midi_tuning_f (t,f0,k,g) n =+    let r = tn_approximate_ratios_cyclic t+        m = take g (map (T.cps_to_midi_detune . (* f0)) r)+    in m `Safe.atMay` T.midi_to_int (n - k)++-- * Midi tuning tables.++-- | midi-note-number -> fractional-midi-note-number table, possibly sparse.+type MNN_FMNN_Table = [(Word8,Double)]++-- | Load 'MNN_FMNN_Table' from two-column CSV file.+mnn_fmnn_table_load_csv :: FilePath -> IO MNN_FMNN_Table+mnn_fmnn_table_load_csv fn = do+  s <- readFile fn+  let f x = case break (== ',') x of+              (lhs,_:rhs) -> (read lhs,read rhs)+              _ -> error "mnn_fmidi_table_load_csv?"+  return (map f (lines s))++-- | Midi-note-number -> CPS table, possibly sparse.+type MNN_CPS_Table = [(T.Midi,Double)]++-- | Generates 'MNN_CPS_Table' given 'Midi_Tuning_F' with keys for all valid @MNN@.+--+-- > import Sound.SC3.Plot+-- > let f = cps_midi_tuning_f (equal_temperament 12,T.midi_to_cps 0,0,127)+-- > plot_p2_ln [map (fmap round) (gen_cps_tuning_tbl f)]+gen_cps_tuning_tbl :: Sparse_Midi_Tuning_F -> MNN_CPS_Table+gen_cps_tuning_tbl tn_f =+    let f n = case tn_f n of+                Just r -> Just (n,T.midi_detune_to_cps r)+                Nothing -> Nothing+    in mapMaybe f [0 .. 127]++-- * Derived (secondary) tuning table (DTT) lookup.++-- | Given an 'MNN_CPS_Table' /tbl/, a list of @CPS@ /c/, and a @MNN@ /m/+-- find the @CPS@ in /c/ that is nearest to the @CPS@ in /t/ for /m/.+-- In equal distance cases bias left.+dtt_lookup :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (Maybe v,Maybe v)+dtt_lookup tbl cps n =+    let f = lookup n tbl+    in (f,fmap (T.find_nearest_err True cps) f)++-- | Require table be non-sparse.+dtt_lookup_err :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (k,v,v)+dtt_lookup_err tbl cps n =+    case dtt_lookup tbl cps n of+      (Just f,Just g) -> (n,f,g)+      _ -> error "dtt_lookup"++-- | Given two tuning tables generate the @dtt@ table.+gen_dtt_lookup_tbl :: MNN_CPS_Table -> MNN_CPS_Table -> MNN_CPS_Table+gen_dtt_lookup_tbl t0 t1 =+    let ix = [0..127]+        cps = sort (map (T.p3_third . dtt_lookup_err t0 (map snd t1)) ix)+    in zip ix cps++gen_dtt_lookup_f :: MNN_CPS_Table -> MNN_CPS_Table -> Midi_Tuning_F+gen_dtt_lookup_f t0 t1 =+    let m = M.fromList (gen_dtt_lookup_tbl t0 t1)+    in T.cps_to_midi_detune . T.map_ix_err m
+ Music/Theory/Tuning/Partch.hs view
@@ -0,0 +1,113 @@+module Music.Theory.Tuning.Partch where++import qualified Data.Map.Strict as M {- containers -}+import Data.Ratio {- base -}++import qualified Music.Theory.Tuning as T++orelate :: Integral i => Ratio i -> i -> Ratio i+orelate r m = T.fold_ratio_to_octave_err (r * (m % 1))++urelate :: Integral i => Ratio i -> i -> Ratio i+urelate r m = T.fold_ratio_to_octave_err (r * (1 % m))++-- | Incipient Tonality Diamond+--+-- > itd_map [4 .. 6]+-- > itd_tbl [4 .. 13]+itd_map :: [Integer] -> M.Map (Int,Int) Rational+itd_map relation =+  let limit = length relation+      z = map (orelate 1) relation+      c0 = zip (map (\n -> (n,0)) [0 .. limit - 1]) z+      cN = [((i,k),urelate (z !! i) (relation !! k)) |+            i <- [0 .. limit - 1],+            k <- [1 .. limit - 1]]+  in M.fromList (c0 ++ cN)++map_to_table :: t -> (Int,Int) -> M.Map (Int,Int) t -> [[t]]+map_to_table k (nr,nc) m =+  [[M.findWithDefault k (i,j) m | j <- [0 .. nc - 1]] | i <- [0 .. nr - 1]]++itd_tbl :: [Integer] -> [[Rational]]+itd_tbl r =+  let err = error "itd_tbl"+      n = length r+  in map_to_table err (n,n) (itd_map r)++{-++import Data.List {- base -}+import qualified Music.Theory.Array.MD as T {- hmt -}+import qualified Music.Theory.Math as T {- hmt -}++pp tbl = putStrLn $ unlines $ intersperse "" $ T.md_table Nothing (map (map T.rational_pp) tbl)++$ itd 4 5 6+  1/1     8/5     4/3++  5/4     1/1     5/3++  3/2     6/5     1/1+$++pp (itd_tbl [4 .. 6])++    --- --- ---+      1 8/5 4/3++    5/4   1 5/3++    3/2 6/5   1+    --- --- ---++$ itd 4 5 6 7 8 9 10 11 12 13+  1/1     8/5     4/3     8/7     1/1    16/9     8/5    16/11    4/3    16/13++  5/4     1/1     5/3    10/7     5/4    10/9     1/1    20/11    5/3    20/13++  3/2     6/5     1/1    12/7     3/2     4/3     6/5    12/11    1/1    24/13++  7/4     7/5     7/6     1/1     7/4    14/9     7/5    14/11    7/6    14/13++  1/1     8/5     4/3     8/7     1/1    16/9     8/5    16/11    4/3    16/13++  9/8     9/5     3/2     9/7     9/8     1/1     9/5    18/11    3/2    18/13++  5/4     1/1     5/3    10/7     5/4    10/9     1/1    20/11    5/3    20/13++ 11/8    11/10   11/6    11/7    11/8    11/9    11/10    1/1    11/6    22/13++  3/2     6/5     1/1    12/7     3/2     4/3     6/5    12/11    1/1    24/13++ 13/8    13/10   13/12   13/7    13/8    13/9    13/10   13/11   13/12    1/1++$++pp (itd_tbl [4 .. 13])++    ---- ----- ----- ---- ---- ---- ----- ----- ----- -----++       1   8/5   4/3  8/7    1 16/9   8/5 16/11   4/3 16/13++     5/4     1   5/3 10/7  5/4 10/9     1 20/11   5/3 20/13++     3/2   6/5     1 12/7  3/2  4/3   6/5 12/11     1 24/13++     7/4   7/5   7/6    1  7/4 14/9   7/5 14/11   7/6 14/13++       1   8/5   4/3  8/7    1 16/9   8/5 16/11   4/3 16/13++     9/8   9/5   3/2  9/7  9/8    1   9/5 18/11   3/2 18/13++     5/4     1   5/3 10/7  5/4 10/9     1 20/11   5/3 20/13++    11/8 11/10  11/6 11/7 11/8 11/9 11/10     1  11/6 22/13++     3/2   6/5     1 12/7  3/2  4/3   6/5 12/11     1 24/13++    13/8 13/10 13/12 13/7 13/8 13/9 13/10 13/11 13/12     1++    ---- ----- ----- ---- ---- ---- ----- ----- ----- -----++-}
Music/Theory/Tuning/Polansky_1978.hs view
@@ -4,7 +4,8 @@  import Data.List {- base -} -import qualified Music.Theory.Tuning as T+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.Type as T {- hmt -}  {- | Three interlocking harmonic series on 1:5:3, by Larry Polansky in \"Psaltery\". @@ -43,4 +44,4 @@  -} psaltery_o :: T.Tuning-psaltery_o = T.Tuning (Left psaltery_o_r) 2+psaltery_o = T.Tuning (Left psaltery_o_r) Nothing
Music/Theory/Tuning/Polansky_1985c.hs view
@@ -2,7 +2,7 @@ -- _1/1, The Journal of the Just Intonation Newtork_, 1(4), Autumn 1985. module Music.Theory.Tuning.Polansky_1985c where -import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}  -- | The tuning has four octaves, these ratios are per-octave. ps5_jpr_r :: [[Rational]]@@ -32,4 +32,4 @@ ps5_jpr =     let f (m,n) = map (* m) n         r = concat (map f (zip [1,2,4,8] ps5_jpr_r))-    in Tuning (Left r) 16+    in Tuning (Left r) (Just (Left 4))
Music/Theory/Tuning/Rosenboom_1979.hs view
@@ -7,6 +7,7 @@ import Data.List {- base -} import Data.Ratio {- base -} +import qualified Music.Theory.Function as T import qualified Music.Theory.List as T import qualified Music.Theory.Pitch as T import qualified Music.Theory.Pitch.Name as T@@ -73,7 +74,7 @@  -- > Scala.scale_verify dr_scale_scala -- > putStrLn $ unlines $ Scala.scale_pp dr_scale_scala-dr_scale_scala :: Scala.Scale Integer+dr_scale_scala :: Scala.Scale dr_scale_scala =     let f (r,(_,p,_,_,_)) = (T.pitch_to_midi p :: Int,r)         sq = map f (zip dr_tuning dr_scale_tbl_12et)
Music/Theory/Tuning/Scala.hs view
@@ -1,7 +1,10 @@--- | Parser for the Scala scale file format.  See--- <http://www.huygens-fokker.org/scala/scl_format.html> for details.--- This module succesfully parses all 4671 scales in v.85 of the scale--- library.+{- | Parser for the Scala scale file format.++See <http://www.huygens-fokker.org/scala/scl_format.html> for details.++This module succesfully parses all scales in v.89 of the scale library.++-} module Music.Theory.Tuning.Scala where  import Control.Monad {- base -}@@ -13,20 +16,23 @@ import System.Environment {- base -} import System.FilePath {- filepath -} +import qualified Music.Theory.Array.CSV as T {- hmt -} import qualified Music.Theory.Directory as T {- hmt -} import qualified Music.Theory.Either as T {- hmt -} import qualified Music.Theory.Function as T {- hmt -} import qualified Music.Theory.IO as T {- hmt -} import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Math.Prime as T {- hmt -} import qualified Music.Theory.Read as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -} import qualified Music.Theory.String as T {- hmt -} import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.Type as T {- hmt -}  -- * Pitch  -- | A @.scl@ pitch is either in 'Cents' or is a 'Ratio'.-type Pitch i = Either T.Cents (Ratio i)+type Pitch = Either T.Cents Rational  -- | An enumeration type for @.scl@ pitch classification. data Pitch_Type = Pitch_Cents | Pitch_Ratio deriving (Eq,Show)@@ -35,11 +41,11 @@ type Epsilon = Double  -- | Derive 'Pitch_Type' from 'Pitch'.-pitch_type :: Pitch i -> Pitch_Type+pitch_type :: Pitch -> Pitch_Type pitch_type = either (const Pitch_Cents) (const Pitch_Ratio)  -- | Pitch as 'T.Cents', conversion by 'T.ratio_to_cents' if necessary.-pitch_cents :: Integral i => Pitch i -> T.Cents+pitch_cents :: Pitch -> T.Cents pitch_cents p =     case p of       Left c -> c@@ -47,14 +53,14 @@  -- | Pitch as 'Rational', conversion by 'T.reconstructed_ratio' if -- necessary, hence /epsilon/.-pitch_ratio :: Epsilon -> Pitch Integer -> Rational+pitch_ratio :: Epsilon -> Pitch -> Rational pitch_ratio epsilon p =     case p of       Left c -> T.reconstructed_ratio epsilon c       Right r -> r  -- | A pair giving the number of 'Cents' and number of 'Ratio' pitches.-pitch_representations :: Integral t => [Pitch i] -> (t,t)+pitch_representations :: [Pitch] -> (Int,Int) pitch_representations =     let f (l,r) p = case p of                       Left _ -> (l + 1,r)@@ -62,132 +68,148 @@     in foldl f (0,0)  -- | If scale is uniform, give type.-uniform_pitch_type :: [Pitch i] -> Maybe Pitch_Type+uniform_pitch_type :: [Pitch] -> Maybe Pitch_Type uniform_pitch_type p =-    case pitch_representations p :: (Int,Int) of+    case pitch_representations p of       (0,_) -> Just Pitch_Ratio       (_,0) -> Just Pitch_Cents       _ -> Nothing  -- | The predominant type of the pitches for 'Scale'.-pitch_type_predominant :: [Pitch i] -> Pitch_Type+pitch_type_predominant :: [Pitch] -> Pitch_Type pitch_type_predominant p =-    let (c,r) = pitch_representations p :: (Int,Int)+    let (c,r) = pitch_representations p     in if c >= r then Pitch_Cents else Pitch_Ratio  -- * Scale --- | A scale has a name, a description, a degree, and a list of 'Pitch'es.-type Scale i = (String,String,Int,[Pitch i])+-- | A scale has a name, a description, a degree, and a sequence of pitches.+--   The /name/ is the the file-name without the /.scl/ suffix.+--   By convention the first comment line gives the file name (with suffix).+--   The pitches do NOT include 1:1 or 0c and do include the octave.+type Scale = (String,String,Int,[Pitch])  -- | The name of a scale.-scale_name :: Scale i -> String+scale_name :: Scale -> String scale_name (nm,_,_,_) = nm  -- | Text description of a scale.-scale_description :: Scale i -> String+scale_description :: Scale -> String scale_description (_,d,_,_) = d  -- | The degree of the scale (number of 'Pitch'es).-scale_degree :: Scale i -> Int+scale_degree :: Scale -> Int scale_degree (_,_,n,_) = n  -- | The 'Pitch'es at 'Scale'.-scale_pitches :: Scale i -> [Pitch i]+scale_pitches :: Scale -> [Pitch] scale_pitches (_,_,_,p) = p +-- | Is 'Pitch' outside of the standard octave (ie. cents 0-1200 and ratios 1-2)+pitch_non_oct :: Pitch -> Bool+pitch_non_oct p =+  case p of+    Left c -> c < 0 || c > 1200+    Right r -> r < 1 || r > 2+ -- | Ensure degree and number of pitches align.-scale_verify :: Scale i -> Bool+scale_verify :: Scale -> Bool scale_verify (_,_,n,p) = n == length p  -- | Raise error if scale doesn't verify, else 'id'.-scale_verify_err :: Scale i -> Scale i-scale_verify_err scl = if scale_verify scl then scl else error "invalid scale"+scale_verify_err :: Scale -> Scale+scale_verify_err scl = if scale_verify scl then scl else error ("invalid scale: " ++ scale_name scl) --- | The last 'Pitch' element of the scale (ie. the /ocatve/).-scale_octave :: Scale i -> Maybe (Pitch i)+-- | The last 'Pitch' element of the scale (ie. the /octave/).  For empty scales give 'Nothing'.+scale_octave :: Scale -> Maybe Pitch scale_octave (_,_,_,s) =     case s of       [] -> Nothing       _ -> Just (last s) --- | Is 'scale_octave' perfect, ie. 'Ratio' of @2@ or 'Cents' of--- @1200@.-perfect_octave :: Integral i => Scale i -> Bool-perfect_octave s = scale_octave s `elem` [Just (Right 2),Just (Left 1200)]+-- | Error variant.+scale_octave_err :: Scale -> Pitch+scale_octave_err = fromMaybe (error "scale_octave?") . scale_octave +-- | Is 'scale_octave' perfect, ie. 'Ratio' of @2@ or 'Cents' of @1200@.+perfect_octave :: Scale -> Bool+perfect_octave s =+  case scale_octave s of+    Just (Right 2) -> True+    Just (Left 1200.0) -> True+    _ -> False+ -- | Are all pitches of the same type.-is_scale_uniform :: Scale i -> Bool+is_scale_uniform :: Scale -> Bool is_scale_uniform = isJust . uniform_pitch_type . scale_pitches --- | Make scale pitches uniform, conforming to the most promininent--- pitch type.-scale_uniform :: Epsilon -> Scale Integer -> Scale Integer+-- | Are the pitches in ascending sequence.+is_scale_ascending :: Scale -> Bool+is_scale_ascending = T.is_ascending . map pitch_cents . scale_pitches++-- | Make scale pitches uniform, conforming to the most predominant pitch type.+scale_uniform :: Epsilon -> Scale -> Scale scale_uniform epsilon (nm,d,n,p) =     case pitch_type_predominant p of       Pitch_Cents -> (nm,d,n,map (Left . pitch_cents) p)       Pitch_Ratio -> (nm,d,n,map (Right . pitch_ratio epsilon) p)  -- | Scale as list of 'T.Cents' (ie. 'pitch_cents') with @0@ prefix.-scale_cents :: Integral i => Scale i -> [T.Cents]+scale_cents :: Scale -> [T.Cents] scale_cents s = 0 : map pitch_cents (scale_pitches s)  -- | 'map' 'round' of 'scale_cents'.-scale_cents_i :: Integral i => Scale i -> [i]+scale_cents_i :: Scale -> [T.Cents_I] scale_cents_i = map round . scale_cents  -- | Scale as list of 'Rational' (ie. 'pitch_ratio') with @1@ prefix.-scale_ratios :: Epsilon -> Scale Integer -> [Rational]+scale_ratios :: Epsilon -> Scale -> [Rational] scale_ratios epsilon s = 1 : map (pitch_ratio epsilon) (scale_pitches s) --- | Require that 'Scale' be uniformlay of 'Ratio's.-scale_ratios_req :: Integral i => Scale i -> [Ratio i]-scale_ratios_req =-    let err = error "scale_ratios_req"-    in (1 :) . map (fromMaybe err . T.fromRight) . scale_pitches---- | Translate 'Scale' to 'T.Tuning'.  If 'Scale' is uniformly--- rational, 'T.Tuning' is rational, else 'T.Tuning' is in 'T.Cents'.--- 'Epsilon' is used to recover the 'Rational' octave if required.-scale_to_tuning :: Epsilon -> Scale Integer -> T.Tuning-scale_to_tuning epsilon (_,_,_,p) =-    case partitionEithers p of-      ([],r) -> let (r',o) = T.separate_last r-                in T.Tuning (Left (1 : r')) o-      _ -> let (c,o) = T.separate_last p-               c' = 0 : map pitch_cents c-               o' = either (T.reconstructed_ratio epsilon) id o-           in T.Tuning (Right c') o'+-- | Require that 'Scale' be uniformly of 'Ratio's.+scale_ratios_u :: Scale -> Maybe [Rational]+scale_ratios_u scl =+  let err = error "scale_ratios_u?"+      p = scale_pitches scl+  in case uniform_pitch_type p of+       Just Pitch_Ratio -> Just (1 : map (fromMaybe err . T.from_right) p)+       _ -> Nothing --- | Convert 'T.Tuning' to 'Scale'.------ > tuning_to_scale ("et12","12 tone equal temperament") (T.equal_temperament 12)-tuning_to_scale :: (String,String) -> T.Tuning -> Scale Integer-tuning_to_scale (nm,dsc) (T.Tuning p o) =-    let n = either length length p-        p' = either (map Right . tail) (map Left . tail) p ++ [Right o]-    in (nm,dsc,n,p')+-- | Erroring variant of 'scale_ratios_u.+scale_ratios_req :: Scale -> [Rational]+scale_ratios_req = fromMaybe (error "scale_ratios_req") . scale_ratios_u  {- | Are scales equal ('==') at degree and tuning data.  > db <- scl_load_db > let r = [2187/2048,9/8,32/27,81/64,4/3,729/512,3/2,6561/4096,27/16,16/9,243/128,2/1]-> let Just py = find (scale_eq ("","",12,map Right r)) db+> let Just py = find (scale_eq ("","",length r,map Right r)) db > scale_name py == "pyth_12" +'scale_eqv' provides an approximate equality function.+ > let c = map T.ratio_to_cents r-> let Just py' = find (scale_eqv ("","",12,map Left c)) db+> let Just py' = find (scale_eqv 0.00001 ("","",length c,map Left c)) db > scale_name py' == "pyth_12"+ -}-scale_eq :: Eq n => Scale n -> Scale n -> Bool+scale_eq :: Scale -> Scale -> Bool scale_eq (_,_,d0,p0) (_,_,d1,p1) = d0 == d1 && p0 == p1 --- | Are scales equal ('==') at degree and tuning data after 'pitch_cents'.-scale_eqv :: Integral n => Scale n -> Scale n -> Bool-scale_eqv (_,_,d0,p0) (_,_,d1,p1) =-    let f = map pitch_cents-    in d0 == d1 && f p0 == f p1+-- | Are scales equal at degree and 'intersect' to at least /k/ places of tuning data.+scale_eq_n :: Int -> Scale -> Scale -> Bool+scale_eq_n k (_,_,d0,p0) (_,_,d1,p1) = d0 == d1 && length (intersect p0 p1) >= k +-- | Is `s1` a proper subset of `s2`.+scale_sub :: Scale -> Scale -> Bool+scale_sub (_,_,d0,p0) (_,_,d1,p1) = d0 < d1 && intersect p0 p1 == p0++-- | Are scales equal at degree and equivalent to within /epsilon/ at 'pitch_cents'.+scale_eqv :: Epsilon -> Scale -> Scale -> Bool+scale_eqv epsilon (_,_,d0,p0) (_,_,d1,p1) =+    let (~=) p q = abs (pitch_cents p - pitch_cents q) < epsilon+    in d0 == d1 && all id (zipWith (~=) p0 p1)+ -- * Parser  -- | Comment lines begin with @!@.@@ -203,35 +225,38 @@ remove_eol_comments :: String -> String remove_eol_comments = takeWhile (/= '!') --- | Remove comments and null lines and trailing comments.+-- | Remove comments and trailing comments (the description may be empty, keep nulls) ----- > filter_comments ["!a","b","","c","d!e"] == ["b","c","d"]+-- > filter_comments ["!a","b","","c","d!e"] == ["b","","c","d"] filter_comments :: [String] -> [String] filter_comments =     map remove_eol_comments .-    filter (not . T.predicate_any [is_comment,null])+    filter (not . T.predicate_any [is_comment])  -- | Pitches are either cents (with decimal point, possibly trailing) or ratios (with @/@). ----- > map parse_pitch ["700.0","350.","3/2","2"] == [Left 700,Left 350,Right (3/2),Right 2]-parse_pitch :: (Read i,Integral i) => String -> Pitch i+-- > map parse_pitch ["70.0","350.","3/2","2","2/1"] == [Left 70,Left 350,Right (3/2),Right 2,Right 2]+parse_pitch :: String -> Pitch parse_pitch p =     if '.' `elem` p     then Left (T.read_fractional_allow_trailing_point_err p)     else Right (T.read_ratio_with_div_err p)  -- | Pitch lines may contain commentary.-parse_pitch_ln :: (Read i, Integral i) => String -> Pitch i+parse_pitch_ln :: String -> Pitch parse_pitch_ln x =     case words x of       p:_ -> parse_pitch p       _ -> error (show ("parse_pitch_ln",words x))  -- | Parse @.scl@ file.-parse_scl :: (Read i, Integral i) => String -> String -> Scale i+parse_scl :: String -> String -> Scale parse_scl nm s =     case filter_comments (lines (T.filter_cr s)) of-      t:n:p -> let scl = (nm,T.delete_trailing_whitespace t,T.read_err n,map parse_pitch_ln p)+      t:n:p -> let scl = (nm+                         ,T.delete_trailing_whitespace t+                         ,T.read_err_msg "degree" n+                         ,map parse_pitch_ln p)                in scale_verify_err scl       _ -> error "parse" @@ -240,7 +265,7 @@ -- | Read the environment variable @SCALA_SCL_DIR@, which is a -- sequence of directories used to locate scala files on. ----- > setEnv "SCALA_DIST_DIR" "/home/rohan/data/scala/85/scl"+-- > setEnv "SCALA_DIST_DIR" "/home/rohan/data/scala/89/scl" scl_get_dir :: IO [String] scl_get_dir = fmap splitSearchPath (getEnv "SCALA_SCL_DIR") @@ -259,8 +284,8 @@ -- then return it, else run 'scl_derive_filename'. -- -- > scl_resolve_name "young-lm_piano"--- > scl_resolve_name "/home/rohan/data/scala/85/scl/young-lm_piano.scl"--- > scl_resolve_name "/home/rohan/data/scala/85/scl/unknown-tuning.scl"+-- > scl_resolve_name "/home/rohan/data/scala/89/scl/young-lm_piano.scl"+-- > scl_resolve_name "/home/rohan/data/scala/89/scl/unknown-tuning.scl" scl_resolve_name :: String -> IO FilePath scl_resolve_name nm =     let ex_f x = if x then return nm else error "scl_resolve_name: file does not exist"@@ -273,59 +298,34 @@ -- > s <- scl_load "xenakis_chrom" -- > pitch_representations (scale_pitches s) == (6,1) -- > scale_ratios 1e-3 s == [1,21/20,29/23,179/134,280/187,11/7,100/53,2]-scl_load :: (Read i, Integral i) => String -> IO (Scale i)+scl_load :: String -> IO Scale scl_load nm = do   fn <- scl_resolve_name nm   s <- T.read_file_iso_8859_1 fn   return (parse_scl (takeBaseName nm) s) --- | 'scale_to_tuning' of 'scl_load'.-scl_load_tuning :: Epsilon -> String -> IO T.Tuning-scl_load_tuning epsilon = fmap (scale_to_tuning epsilon) . scl_load--{- | Load all @.scl@ files at /dir/.--> dir <- scl_get_dir-> dir == ["/home/rohan/data/scala/85/scl","/home/rohan/sw/hmt/data/scl"]-> let [scl_85_dir,ext_dir] = dir-> db <- scl_load_dir scl_85_dir-> length db == 4671-> length (filter ((== 0) . scale_degree) db) == 0-> length (filter ((/= 1) . head . scale_ratios 1e-3) db) == 0-> length (filter ((/= 0) . head . scale_cents) db) == 0-> length (filter (== Just (Right 2)) (map scale_octave db)) == 4003-> length (filter is_scale_uniform db) == 2816--> let na = filter (not . T.is_ascending . scale_cents) db-> length na == 121-> mapM_ (putStrLn . unlines . scale_stat) na--> import qualified Music.Theory.List as T-> import Sound.SC3.Plot-> plot_p2_stp [T.histogram (map scale_degree db)]--> import Data.List--> let r = ["Xenakis's Byzantine Liturgical mode, 5 + 19 + 6 parts"->         ,"Xenakis's Byzantine Liturgical mode, 12 + 11 + 7 parts"->         ,"Xenakis's Byzantine Liturgical mode, 7 + 16 + 7 parts"]-> in filter (isInfixOf "Xenakis") (map scale_description db) == r--> let r = ["LaMonte Young, tuning of For Guitar '58. 1/1 March '92, inv.of Mersenne lute 1"->         ,"LaMonte Young's Well-Tuned Piano"]-> in filter (isInfixOf "LaMonte Young") (map scale_description db) == r+{- | Load all @.scl@ files at /dir/, associate with file-name. -> length (filter (not . perfect_octave) db) == 663+> db <- scl_load_dir_fn "/home/rohan/data/scala/89/scl"+> length db == 5050 -- v.89+> map (\(fn,s) -> (takeFileName fn,scale_name s)) db  -}-scl_load_dir :: (Read i, Integral i) => FilePath -> IO [Scale i]-scl_load_dir d = T.dir_subset [".scl"] d >>= mapM scl_load+scl_load_dir_fn :: FilePath -> IO [(FilePath,Scale)]+scl_load_dir_fn d = do+  fn <- T.dir_subset [".scl"] d+  scl <- mapM scl_load fn+  return (zip fn scl) +-- | 'snd' of 'scl_load_dir_fn'+scl_load_dir :: FilePath -> IO [Scale]+scl_load_dir = fmap (map snd) . scl_load_dir_fn+ -- | Load Scala data base at 'scl_get_dir'. -- -- > db <- scl_load_db--- > mapM_ (putStrLn.unlines.scale_stat) (filter (not . perfect_octave) db)-scl_load_db :: (Read i, Integral i) => IO [Scale i]+-- > mapM_ (putStrLn . unlines . scale_stat) (filter (not . perfect_octave) db)+scl_load_db :: IO [Scale] scl_load_db = do   dir <- scl_get_dir   r <- mapM scl_load_dir dir@@ -333,21 +333,42 @@  -- * PP -scale_stat :: (Integral i,Show i) => Scale i -> [String]+-- | <http://www.huygens-fokker.org/docs/scalesdir.txt>+scales_dir_txt_tbl :: [Scale] -> [[String]]+scales_dir_txt_tbl =+  let f s = [scale_name s,show (scale_degree s),scale_description s]+  in map f++-- | Format as CSV file.+--+-- > db <- scl_load_db+-- > writeFile "/tmp/scl.csv" (scales_dir_txt_csv db)+scales_dir_txt_csv :: [Scale] -> String+scales_dir_txt_csv db = T.csv_table_pp id T.def_csv_opt (Nothing,scales_dir_txt_tbl db)++-- | Simple plain-text display of scale data.+--+-- > db <- scl_load_db+-- > writeFile "/tmp/scl.txt" (unlines (intercalate [""] (map scale_stat db)))+scale_stat :: Scale -> [String] scale_stat s =-    let ty = uniform_pitch_type (scale_pitches s)-    in ["scale-name        : " ++ scale_name s-       ,"scale-description : " ++ scale_description s-       ,"scale-degree      : " ++ show (scale_degree s)-       ,"scale-type        : " ++ maybe "non-uniform" show ty-       ,"perfect-octave    : " ++ show (perfect_octave s)-       ,"scale-cents-i     : " ++ show (scale_cents_i s)-       ,if ty == Just Pitch_Ratio-        then "scale-ratios      : " ++ intercalate "," (map T.rational_pp (scale_ratios_req s))+    let p = scale_pitches s+        u_ty = uniform_pitch_type p+        n_ty = let p_ty = pitch_type_predominant p+                   (p_i,p_j) = pitch_representations p+               in concat ["non-uniform (",show p_ty,",",show p_i,":",show p_j,")"]+    in ["name        : " ++ scale_name s+       ,"description : " ++ scale_description s+       ,"degree      : " ++ show (scale_degree s)+       ,"type        : " ++ maybe n_ty show u_ty+       ,"perfect-oct : " ++ show (perfect_octave s)+       ,"cents-i     : " ++ show (scale_cents_i s)+       ,if u_ty == Just Pitch_Ratio+        then "ratios      : " ++ intercalate "," (map T.rational_pp (scale_ratios_req s))         else ""]  -- | Pretty print 'Pitch' in @Scala@ format.-pitch_pp :: Show i => Pitch i -> String+pitch_pp :: Pitch -> String pitch_pp p =     case p of       Left c -> show c@@ -355,10 +376,10 @@  -- | Pretty print 'Scale' in @Scala@ format. ----- > s <- scl_load "et19"--- > s <- scl_load "young-lm_piano"--- > putStr $ unlines $ scale_pp s-scale_pp :: Show i => Scale i -> [String]+-- > scl <- scl_load "et19"+-- > scl <- scl_load "young-lm_piano"+-- > putStr $ unlines $ scale_pp scl+scale_pp :: Scale -> [String] scale_pp (nm,dsc,k,p) =     ["! " ++ nm ++ ".scl"     ,"!"@@ -366,6 +387,13 @@     ,show k     ,"!"] ++ map pitch_pp p +scale_wr :: FilePath -> Scale -> IO ()+scale_wr fn = writeFile fn . unlines . scale_pp++-- | Write /scl/ to /dir/ with the file-name 'scale_name'.scl+scale_wr_dir :: FilePath -> Scale -> IO ()+scale_wr_dir dir scl = scale_wr (dir </> scale_name scl <.> "scl") scl+ -- * DIST  -- | @scala@ distribution directory, given at @SCALA_DIST_DIR@.@@ -375,10 +403,104 @@ dist_get_dir = getEnv "SCALA_DIST_DIR"  -- | Load file from 'dist_get_dir'.------ > s <- load_dist_file "intnam.par"--- > length s == 473-load_dist_file :: FilePath -> IO [String]+load_dist_file :: FilePath -> IO String load_dist_file nm = do   d <- dist_get_dir-  fmap lines (readFile (d </> nm))+  readFile (d </> nm)++-- | 'fmap' 'lines' 'load_dist_file'+--+-- > s <- load_dist_file_ln "intnam.par"+-- > length s == 533 -- Scala 2.42p+load_dist_file_ln :: FilePath -> IO [String]+load_dist_file_ln = fmap lines . load_dist_file++-- * QUERY++-- | Is scale just-intonation (ie. are all pitches ratios)+scl_is_ji :: Scale -> Bool+scl_is_ji = (==) (Just Pitch_Ratio) . uniform_pitch_type . scale_pitches++-- | Calculate limit for JI scale (ie. largest prime factor)+scl_ji_limit :: Scale -> Integer+scl_ji_limit = maximum . map fst . concatMap T.rational_prime_factors_m . scale_ratios_req++-- | Sum of absolute differences to scale given in cents, sorted, with rotation.+scl_cdiff_abs_sum :: [T.Cents] -> Scale -> [(Double,[T.Cents],Int)]+scl_cdiff_abs_sum c scl =+  let r = map (T.dx_d 0) (T.rotations (T.d_dx (sort (scale_cents scl))))+      ndiff x i = let d = zipWith (-) c x in (sum (map abs d),d,i)+  in sort (zipWith ndiff r [0..])++{- | Variant selecting only nearest and with post-processing function.++> scl <- scl_load "holder"+> scale_cents_i scl+> c = [0,83,193,308,388,502,584,695,778,890,1004,1085,1200]+> (_,r,_) = scl_cdiff_abs_sum_1 round c scl+> r == [0,2,-1,1,0,-1,0,-1,0,0,0,0,0]+-}+scl_cdiff_abs_sum_1 :: (Double -> n) -> [T.Cents] -> Scale -> (Double,[n],Int)+scl_cdiff_abs_sum_1 pp c scl =+  case scl_cdiff_abs_sum c scl of+    [] -> error "scl_cdiff_abs_sum_1"+    (n,d,r):_ -> (n,map pp d,r)++{- | Sort DB into ascending order of sum of absolute of differences to scale given in cents.+     Scales are sorted and all rotations are considered.++> db <- scl_load_db+> c = [0,83,193,308,388,502,584,695,778,890,1004,1085,1200]+> r = scl_db_query_cdiff_asc round db c+> ((_,dx,_),_):_ = r+> dx == [0,2,-1,1,0,-1,0,-1,0,0,0,0,0]+> mapM_ (putStrLn . unlines . scale_stat . snd) (take 10 r)+-}+scl_db_query_cdiff_asc :: Ord n => (Double -> n) -> [Scale] -> [T.Cents] -> [((Double,[n],Int),Scale)]+scl_db_query_cdiff_asc pp db c =+  let n = length c - 1+      db_n = filter ((== n) . scale_degree) db+  in sort (map (\scl -> (scl_cdiff_abs_sum_1 pp c scl,scl)) db_n)++-- | Is /x/ the same scale as /scl/ under /cmp/.+scale_cmp_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> Scale -> Bool+scale_cmp_ji cmp x scl =+  case scale_ratios_u scl of+    Nothing -> False+    Just r -> cmp x r++-- | Find scale(s) that are 'scale_cmp_ji' to /x/.+--   Usual /cmp/ are (==) and 'is_subset'.+scl_find_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> IO [Scale]+scl_find_ji cmp x = do+  db <- scl_load_db+  return (filter (scale_cmp_ji cmp x) db)++-- * Tuning++-- | Translate 'Scale' to 'T.Tuning'.  If 'Scale' is uniformly+-- rational, 'T.Tuning' is rational, else it is in 'T.Cents'.+scale_to_tuning :: Scale -> T.Tuning+scale_to_tuning (_,_,_,p) =+    case partitionEithers p of+      ([],r) -> let (r',o) = T.separate_last r+                in T.Tuning (Left (1 : r')) (if o == 2 then Nothing else Just (Left o))+      _ -> let (c,o) = T.separate_last p+               c' = 0 : map pitch_cents c+               o' = if o == Left 1200 || o == Right 2 then Nothing else Just (T.either_swap o)+           in T.Tuning (Right c') o'++-- | Convert 'T.Tuning' to 'Scale'.+--+-- > tuning_to_scale ("et12","12 tone equal temperament") (T.tn_equal_temperament 12)+tuning_to_scale :: (String,String) -> T.Tuning -> Scale+tuning_to_scale (nm,dsc) tn@(T.Tuning p _) =+    let n = either length length p+        p' = either (map Right . tail) (map Left . tail) p ++ [T.either_swap (T.tn_octave_def tn)]+    in (nm,dsc,n,p')++-- | 'scale_to_tuning' of 'scl_load'.+--+-- > fmap T.tn_limit (scl_load_tuning "pyra") -- Just 59+scl_load_tuning :: String -> IO T.Tuning+scl_load_tuning = fmap scale_to_tuning . scl_load
Music/Theory/Tuning/Scala/Interval.hs view
@@ -1,11 +1,11 @@--- | Parser for the @intnam.par@ file.+-- | Parser for the SCALA @intnam.par@ file. module Music.Theory.Tuning.Scala.Interval where  import Data.Char {- base -} import Data.List {- base -} -import qualified Music.Theory.Read as T {- hmt -}-import qualified Music.Theory.Tuning.Scala as T+import qualified Music.Theory.Read as Read {- hmt -}+import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}  -- | Interval and name, ie. (3/2,"perfect fifth") type INTERVAL = (Rational,String)@@ -13,21 +13,22 @@ -- | Length prefixed list of 'INTERVAL'. type INTNAM = (Int,[INTERVAL]) --- | Lookup ratio in 'INTNAM'.------ > db <- load_intnam--- > intnam_search_ratio db (3/2) == Just (3/2,"perfect fifth")--- > intnam_search_ratio db (2/3) == Nothing--- > intnam_search_ratio db (4/3) == Just (4/3,"perfect fourth")--- > map (intnam_search_ratio db) [3/2,4/3,7/4,7/6,9/7,12/7,14/9]--- > intnam_search_ratio db (31/16) == Just (31/16,"31st harmonic")+{- | Lookup ratio in 'INTNAM'.++> db <- load_intnam+> intnam_search_ratio db (3/2) == Just (3/2,"perfect fifth")+> intnam_search_ratio db (2/3) == Nothing+> intnam_search_ratio db (4/3) == Just (4/3,"perfect fourth")+> intnam_search_ratio db (31/16) == Just (31/16,"=31st harmonic")+> map (intnam_search_ratio db) [3/2,4/3,7/4,7/6,9/7,12/7,14/9]+-} intnam_search_ratio :: INTNAM -> Rational -> Maybe INTERVAL intnam_search_ratio (_,i) x = find ((== x) . fst) i  -- | Lookup interval name in 'INTNAM', ci = case-insensitive. -- -- > db <- load_intnam--- > intnam_search_description_ci db "didymus"+-- > intnam_search_description_ci db "didymus" == [(81/80,"syntonic comma, Didymus comma")] intnam_search_description_ci :: INTNAM -> String -> [INTERVAL] intnam_search_description_ci (_,i) x =     let downcase = map toLower@@ -36,27 +37,32 @@  -- * Parser -parse_intnam_entry :: [String] -> INTERVAL-parse_intnam_entry w =-    case w of-      r:w' -> (T.read_ratio_with_div_err r,unwords w')+-- | Parse line from intnam.par+parse_intnam_entry :: String -> INTERVAL+parse_intnam_entry str =+    case words str of+      r:w -> (Read.read_ratio_with_div_err r,unwords w)       _ -> error "parse_intnam_entry" +-- | Parse non-comment lines from intnam.par parse_intnam :: [String] -> INTNAM parse_intnam l =     case l of       _:n:i -> let n' = read n :: Int-                   i' = map (parse_intnam_entry . words) i+                   i' = map parse_intnam_entry i                in if n' == length i' then (n',i') else error "parse_intnam"       _ -> error "parse_intnam"  -- * IO --- | 'parse_intnam' of 'T.load_dist_file' of "intnam.par".------ > intnam <- load_intnam--- > fst intnam == length (snd intnam)+{- | 'parse_intnam' of 'Scala.load_dist_file_ln' of "intnam.par".++> intnam <- load_intnam+> fst intnam == 516 -- Scala 2.42p+> fst intnam == length (snd intnam)+> lookup (129140163/128000000) (snd intnam) == Just "gravity comma"+-} load_intnam :: IO INTNAM load_intnam = do-  l <- T.load_dist_file "intnam.par"-  return (parse_intnam (T.filter_comments l))+  l <- Scala.load_dist_file_ln "intnam.par"+  return (parse_intnam (Scala.filter_comments l))
+ Music/Theory/Tuning/Scala/KBM.hs view
@@ -0,0 +1,132 @@+{- | Scala "keyboard mapping" files (.kbm) and related data structure.++<http://www.huygens-fokker.org/scala/help.htm#mappings>+-}+module Music.Theory.Tuning.Scala.KBM where++import qualified Music.Theory.Directory as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Tuning.Scala as T {- hmt -}++{- | Scala keyboard mapping++(sz,(m0,mN),mC,(mF,f),o,m)++- sz      = size of map, the pattern repeats every so many keys+- (m0,mN) = the first and last midi note numbers to retune+- mC      = the middle note where the first entry of the mapping is mapped to+- (mF,f)  = the reference midi-note for which a frequency is given, ie. (69,440)+- o       = scale degree to consider as formal octave+- m       = mapping, numbers represent scale degrees mapped to keys, Nothing indicates no mapping++-}+type KBM = (Int,(Int,Int),Int,(Int,Double),Int,[Maybe Int])++-- | Is /mnn/ in range?+kbm_in_rng :: KBM -> Int -> Bool+kbm_in_rng (_,(m0,mN),_,_,_,_) mnn = mnn >= m0 && mnn <= mN++-- | Is /kbm/ linear?, ie. is size zero? (formal-octave may or may not be zero)+kbm_is_linear :: KBM -> Bool+kbm_is_linear (sz,_,_,_,_o,_) = sz == 0 -- && o == 0++{- | Given kbm and midi-note-number lookup (octave,scale-degree).++> k <- kbm_load_dist "example.kbm" -- 12-tone scale+> k <- kbm_load_dist "a440.kbm" -- linear+> k <- kbm_load_dist "white.kbm" -- 7-tone scale on white notes+> k <- kbm_load_dist "black.kbm" -- 5-tone scale on black notes+> k <- kbm_load_dist "128.kbm"++> map (kbm_lookup k) [48 .. 72]++-}+kbm_lookup :: KBM -> Int -> Maybe (Int,Int)+kbm_lookup kbm mnn =+  if not (kbm_in_rng kbm mnn)+  then Nothing+  else if kbm_is_linear kbm+       then Just (0,mnn)+       else let (sz,(_m0,_mN),mC,(_mF,_f),_o,m) = kbm+                (oct,ix) = ((mnn - mC) `divMod` sz)+            in maybe Nothing (\dgr -> Just (oct,dgr)) (m !! ix)++-- | Return the triple (mF,kbm_lookup k mF,f).  The lookup for mF is not-nil by definition.+--+-- > kbm_lookup_mF k+kbm_lookup_mF :: KBM -> (Int,(Int,Int),Double)+kbm_lookup_mF k@(_,_,_,(mF,f),_,_) =+  case kbm_lookup k mF of+    Nothing -> error "kbm_lookup_mF?"+    Just r -> (mF,r,f)++-- | Parser for scala .kbm file.+kbm_parse :: String -> KBM+kbm_parse s =+  let f x = case x of+              "x" -> Nothing+              _ -> Just (read x)+      to_m sz = T.pad_right_no_truncate Nothing sz . map f -- _err -- some scala .kbm have |m| > sz?+  in case T.filter_comments (lines s) of+       i1:i2:i3:i4:i5:d1:i6:m ->+         let sz = read i1+         in (sz,(read i2,read i3),read i4,(read i5,read d1),read i6,to_m sz m)+       _ -> error "kbm_parse?"++-- | 'kbm_parse' of 'readFile'+kbm_load :: FilePath -> IO KBM+kbm_load = fmap kbm_parse . readFile++{- | 'kbm_parse' of 'T.load_dist_file'++> kbm_load_dist "example.kbm"+> kbm_load_dist "bp.kbm"+> kbm_load_dist "7.kbm" -- error+> kbm_load_dist "8.kbm" -- error+> kbm_load_dist "white.kbm" -- error+> kbm_load_dist "black.kbm" -- error+> kbm_load_dist "128.kbm"+> kbm_load_dist "a440.kbm"+> kbm_load_dist "61.kbm"+-}+kbm_load_dist :: FilePath -> IO KBM+kbm_load_dist = fmap kbm_parse . T.load_dist_file++kbm_load_dir_fn :: FilePath -> IO [(FilePath, KBM)]+kbm_load_dir_fn d = do+  fn <- T.dir_subset [".kbm"] d+  kbm <- mapM kbm_load fn+  return (zip fn kbm)++{- | Load all .kbm files at scala DIST dir.++> db <- kbm_load_dist_dir_fn+> x = map (\(fn,(sz,_,_,_,o,m)) -> (System.FilePath.takeFileName fn,sz,length m,o)) db+> filter (\(_,i,j,_) -> i < j) x+> filter (\(_,i,_,k) -> i == 0 && k == 0) x++> map (\(fn,k) -> (System.FilePath.takeFileName fn,kbm_lookup_mF k)) db+-}+kbm_load_dist_dir_fn :: IO [(FilePath, KBM)]+kbm_load_dist_dir_fn = T.dist_get_dir >>= kbm_load_dir_fn++{- | Pretty-printer for scala .kbm file.++> m <- kbm_load_dist "7.kbm"+> kbm_parse (kbm_pp m) == m+-}+kbm_pp :: KBM -> String+kbm_pp (i1,(i2,i3),i4,(i5,d1),i6,m) =+  let from_m = map (maybe "x" show)+  in unlines ([show i1,show i2,show i3,show i4,show i5,show d1,show i6] ++ from_m m)++-- | 'writeFile' of 'kbm_pp'+kbm_wr :: FilePath -> KBM -> IO ()+kbm_wr fn = writeFile fn . kbm_pp++{- | Standard 12-tone mapping with A=440hz (ie. example.kbm)++> fmap (== kbm_d12_a440) (kbm_load_dist "example.kbm")+-}+kbm_d12_a440 :: KBM+kbm_d12_a440 = (12,(0,127),60,(69,440.0),12,map Just [0 .. 11])
+ Music/Theory/Tuning/Scala/Meta.hs view
@@ -0,0 +1,176 @@+-- | Scala DB meta-data.+module Music.Theory.Tuning.Scala.Meta where++-- | Just-intonation (ie. all rational) scales, collected by author.+scl_ji_au :: [(String,[String])]+scl_ji_au =+  [("Alves, Bill",words "alves_12 alves_22 alves_pelog alves alves_slendro")+  ,("Archytas"+   ,["arch_chrom","arch_chromc2" -- "archchro" NON-JI+    ,"arch_dor"+    ,"arch_enh","arch_enh2","arch_enh3","arch_enhp"+    ,"arch_enht","arch_enht2","arch_enht3","arch_enht4","arch_enht5","arch_enht6","arch_enht7"+    ,"arch_mult"+    ,"arch_ptol","arch_ptol2"+    ,"arch_sept"+    -- "archytas7" "archytas12","archytas12sync" NON-JI+    ])+  ,("Barlow, Clarence",words "barlow_13 barlow_17")+  ,("Boethius",words "boeth_chrom boeth_enh")+  ,("Burt, Warren",+     concat [map (\n -> "burt" ++ show n) [1::Int .. 20]+            ,words "burt_fibo burt_fibo23 burt_forks burt_primes"])+  ,("Chalmers, John"+   ,["chalmers"+    ,"chalmers_17"+    ,"chalmers_19"+    ,"chalmers_ji1"+    ,"chalmers_ji2"+    ,"chalmers_ji3"+    ,"chalmers_ji4"+    ,"corner7"+    ,"corner11"+    ,"corner13"+    ,"corners7"+    ,"corners11"+    ,"corners13"+    ,"finnamore_jc"+    ,"hamilton_jc"+    ,"major_clus"+    ,"major_wing"+    ,"minor_clus"+    ,"minor_wing"+    ,"pelog_jc"+    ,"prod7d"+    ,"prodq13"+    ,"slen_pel_jc"])+  ,("Didymus", words "didy_chrom didy_chrom1 didy_chrom2 didy_chrom3 didy_diat didy_enh didy_enh2")+  ,("Eratosthenes",words "eratos_chrom eratos_diat eratos_enh")+  ,("Euler, Leonhard",words "euler euler_diat euler_enh euler_gm")+  ,("Gann, Kyle",words "gann_arcana gann_charingcross gann_cinderella gann_custer gann_fractured gann_fugitive gann_ghost gann_love gann_new_aunts gann_revisited gann_sitting gann_solitaire gann_suntune gann_super gann_things gann_wolfe hulen_33")+  ,("Grady, Kraig"+   ,["dekany-cs"+    ,"grady11"+    ,"grady_14"+    ,"grady_centaur"+    ,"grady_centaur17"+    ,"grady_centaur19"])+  ,("Harrison, Lou"+   ,["dudon_slendro_matrix" -- NON-UNIQ+    ,"harrison_5"+    ,"harrison_5_1"+    ,"harrison_5_3" -- NON-STEP+    ,"harrison_5_4" -- NON-STEP+    ,"harrison_8" -- NON-STEP+    ,"harrison_15"+    ,"harrison_16"+    ,"harrison_bill"+    ,"harrison_cinna"+    ,"harrison_diat"+    ,"harrison_handel"+    ,"harrison_kyai" -- NON-STEP+    ,"harrison_mid"+    ,"harrison_mid2"+    ,"harrison_mix2"+    ,"harrison_mix3" -- NON-STEP+    ,"harrison_mix4"+    ,"harrison_slye"+    ,"harrison_songs"+    ,"hexany10"+    ,"korea_5"+    ,"pelog_jc" -- STRICT SONGS+    ,"pelog_laras" -- NON-STEP+    ,"prime_5"+    ,"slendro5_1"+    ,"slendro_7_1"+    ,"slendro_7_2"+    ,"slendro_7_3"+    ,"slendro_7_4"]) -- "slendro_laras" -- NON-OCT+  ,("Johnston, Ben"+   ,["johnston"+    ,"johnston_21"+    ,"johnston_22"+    ,"johnston_25"+    ,"johnston_81"+    ,"johnston_6-qt"+    ,"johnston_6-qt_row"])+  ,("Kepler, Johannes",words "kepler1 kepler2 kepler3")+  ,("Partch, Harry"+   ,["kring1"+    ,"diamond7"+    ,"diamond9"+    ,"diamond17b"+    ,"novaro15"+    ,"partch_29-av"+    ,"partch_29"+    ,"partch_37"+    ,"partch_39"+    ,"partch_41"+    ,"partch_43"+    ,"partch-barstow"])+  ,("Ptolemy"+   ,["ptolemy_chrom"+    ,"ptolemy_ddiat"+    ,"ptolemy_diat","ptolemy_diat2","ptolemy_diat3","ptolemy_diat4","ptolemy_diat5"+    ,"ptolemy_diff"+    ,"ptolemy_enh"+    ,"ptolemy_exp"+    ,"ptolemy_ext"+    ,"ptolemy_hominv","ptolemy_hominv2"+    ,"ptolemy_hom"+    ,"ptolemy_iastaiol","ptolemy_iast"+    ,"ptolemy_ichrom"+    ,"ptolemy_idiat"+    ,"ptolemy_imix"+    ,"ptolemy_malak","ptolemy_malak2"+    ,"ptolemy_mdiat","ptolemy_mdiat2","ptolemy_mdiat3"+    ,"ptolemy_meta"+    ,"ptolemy_mix"+    ,"ptolemy_perm"+    ,"ptolemy_prod"+    ,"ptolemy"+    ,"ptolemy_tree"])+  ,("Pythagoras"+   ,["pyth_7a","pyth_12","pyth_12s","pyth_17","pyth_17s","pyth_22","pyth_27","pyth_chrom"+    -- "pyth_31" "pyth_sev" "pyth_third" NOT-JI+    ])+  ,("Riley, Terry",words "riley_albion riley_rosary")+  ,("Tenney, James",words "mund45 tenney_8 tenney_11 tenn41a tenn41b tenn41c")+  ,("Wilson, Erv"+   ,["chin_7"+    ,"ckring9"+    ,"diamond7-13"+    ,"hexany_union"+    ,"novaro15"+    ,"partch_29"+    ,"ptolemy_diat2","ptolemy_idiat"+    ,"slendro5_2"+    ,"stelhex1","stelhex2","stelhex5","stelhex6" -- stelhex3 stelhex4+    ,"wilson1","wilson2","wilson3","wilson5","wilson7","wilson11"+    ,"wilson7_2","wilson7_3","wilson7_4"+    ,"wilson_17","wilson_31","wilson_41"+    ,"wilcent17"+    ,"wilson_alessandro"+    ,"wilson_bag"+    ,"wilson_class"+    ,"wilson_dia1","wilson_dia2","wilson_dia3","wilson_dia4"+    ,"wilson_duo"+    ,"wilson_enh","wilson_enh2"+    ,"wilson_facet"+    -- ,"wilson_gh1","wilson_gh2","wilson_gh11","wilson_gh50" -- NON-JI+    ,"wilson_hebdome1"+    ,"wilson_hexflank"+    ,"wilson_hypenh"+    ,"wilson-rastbayyati24"+    ,"wilson_l1","wilson_l2","wilson_l3","wilson_l4","wilson_l5","wilson_l6"])+  ,("Young, La Monte",["young-lm_guitar","young-lm_piano"])+  ]++{-+import Music.Theory.Tuning.Scala+db <- scl_load_db+nm = concatMap snd scl_ji_au+scl = filter (\x -> scale_name x `elem` nm) db+non_ji = filter (not . scl_is_ji) scl+map scale_name non_ji+-}
Music/Theory/Tuning/Scala/Mode.hs view
@@ -5,9 +5,9 @@ import Data.List {- base -} import Data.Maybe {- base -} -import qualified Music.Theory.Function as T-import qualified Music.Theory.List as T-import qualified Music.Theory.Tuning.Scala as T+import qualified Music.Theory.Function as Function {- hmt -}+import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}  -- | (start-degree,intervals,description) type MODE = (Int,[Int],String)@@ -46,7 +46,7 @@ -- > sq [2,1,2,1,2,1,2,1] -- > sq (replicate 12 1) modenam_search_seq1 :: MODENAM -> [Int] -> Maybe MODE-modenam_search_seq1 mn = T.unlist1 . modenam_search_seq mn+modenam_search_seq1 mn = List.unlist1 . modenam_search_seq mn  -- | Search for mode by description text. --@@ -69,10 +69,11 @@ -- > map non_implicit_degree ["4","[4]"] == [Nothing,Just 4] non_implicit_degree :: String -> Maybe Int non_implicit_degree s =-    case T.unbracket s of-      Just ('[',s',']') -> Just (read s')+    case List.unbracket s of+      Just ('[',x,']') -> Just (read x)       _ -> Nothing +-- | Predicate form is_non_implicit_degree :: String -> Bool is_non_implicit_degree = isJust . non_implicit_degree @@ -81,7 +82,7 @@  parse_modenam_entry :: [String] -> MODE parse_modenam_entry w =-    let (n0:n,c) = span (T.predicate_or is_non_implicit_degree is_integer) w+    let (n0:n,c) = span (Function.predicate_or is_non_implicit_degree is_integer) w     in case non_implicit_degree n0 of          Nothing -> (0,map read (n0:n),unwords c)          Just d -> (d,map read n,unwords c)@@ -90,28 +91,30 @@ join_long_lines :: [String] -> [String] join_long_lines l =     case l of-      p:q:l' -> case T.separate_last' p of+      p:q:l' -> case List.separate_last' p of                   (p',Just '\\') -> join_long_lines ((p' ++ q) : l')                   _ -> p : join_long_lines (q : l')       _ -> l +-- | Parse joined non-comment lines of modenam file. parse_modenam :: [String] -> MODENAM parse_modenam l =     case l of-      n:x:m -> let n' = read n :: Int-                   x' = read x :: Int-                   m' = map (parse_modenam_entry . words) m-               in if n' == length m' then (n',x',m') else error "parse_modenam"+      n_str:x_str:m_str ->+        let n = read n_str :: Int+            x = read x_str :: Int+            m = map (parse_modenam_entry . words) m_str+        in if n == length m then (n,x,m) else error "parse_modenam"       _ -> error "parse_modenam"  -- * IO --- | 'parse_modenam' of 'T.load_dist_file' of @modenam.par@.+-- | 'parse_modenam' of 'Scala.load_dist_file' of @modenam.par@. -- -- > mn <- load_modenam -- > let (n,x,m) = mn--- > n == 2125 && x == 15 && length m == n+-- > n == 2933 && x == 15 && length m == n -- Scala 2.42p load_modenam :: IO MODENAM load_modenam = do-  l <- T.load_dist_file "modenam.par"-  return (parse_modenam (T.filter_comments (join_long_lines l)))+  l <- Scala.load_dist_file_ln "modenam.par"+  return (parse_modenam (Scala.filter_comments (join_long_lines l)))
Music/Theory/Tuning/Sethares_1994.hs view
@@ -28,7 +28,7 @@ fig_1 :: (Floating n,Enum n,Ord n) => [[n]] fig_1 =     let f0 = [125,250,500,1000,2000]-        r_seq = map T.cents_to_ratio [0 .. 1200]+        r_seq = map T.cents_to_fratio [0 .. 1200]     in map (\f -> map (\r -> d (f,1) (f * r,1)) r_seq) f0  -- > let a_seq = take 7 (iterate (* 0.88) 1.0)
Music/Theory/Tuning/Syntonic.hs view
@@ -4,6 +4,7 @@ import Data.List {- base -}  import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}  -- | Construct an isomorphic layout of /r/ rows and /c/ columns with -- an upper left value of /(i,j)/.@@ -18,7 +19,7 @@ -- | A minimal isomorphic note layout. -- -- > let [i,j,k] = mk_isomorphic_layout 3 5 (3,-4)--- > in [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout+-- > [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)]@@ -40,21 +41,21 @@       t = map (rank_two_regular_temperament 1200 b) l   in nub (sort (map (\x -> fromIntegral (x `mod` 1200)) (concat t))) --- | 'mk_syntonic_tuning' of @697@.------ > divisions syntonic_697 == 17------ > let c = [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164]--- > in cents_i syntonic_697 == c+{- | 'mk_syntonic_tuning' of @697@.++> tn_divisions syntonic_697 == 17++> let c = [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164]+> tn_cents_i syntonic_697 == c+-} syntonic_697 :: Tuning-syntonic_697 = Tuning (Right (mk_syntonic_tuning 697)) 2+syntonic_697 = Tuning (Right (mk_syntonic_tuning 697)) Nothing  -- | 'mk_syntonic_tuning' of @702@. ----- > divisions syntonic_702 == 17+-- > tn_divisions syntonic_702 == 17 -- -- > let c = [0,24,114,204,294,318,408,498,522,612,702,792,816,906,996,1020,1110]--- > in cents_i syntonic_702 == c+-- > tn_cents_i syntonic_702 == c syntonic_702 :: Tuning-syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) 2-+syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) Nothing
+ Music/Theory/Tuning/Type.hs view
@@ -0,0 +1,166 @@+-- | Tuning type+module Music.Theory.Tuning.Type where++import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Music.Theory.Either as T {- hmt -}+import qualified Music.Theory.Math.Prime as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}++-- * Tuning++-- | A tuning specified 'Either' as a sequence of exact ratios, or as+-- a sequence of possibly inexact 'Cents', and an octave if not 2:1 or 1200.+--+-- In both cases, the values are given in relation to the first degree+-- of the scale, which for ratios is 1 and for cents 0.+data Tuning = Tuning {tn_ratios_or_cents :: Either [Rational] [T.Cents]+                     ,tn_octave :: Maybe (Either Rational T.Cents)}+              deriving (Eq,Show)++-- | Default epsilon for recovering ratios from cents.+tn_epsilon :: Double+tn_epsilon = 0.001++-- | Tuning value as rational, reconstructed if required.+tn_as_ratio :: Double -> Either Rational T.Cents -> Rational+tn_as_ratio epsilon = either id (T.reconstructed_ratio epsilon)++-- | Tuning value as cents.+tn_as_cents :: Either Rational T.Cents -> T.Cents+tn_as_cents = either T.ratio_to_cents id++-- | Tuning octave, defaulting to 2:1.+tn_octave_def :: Tuning -> Either Rational T.Cents+tn_octave_def = maybe (Left 2) id . tn_octave++-- | Tuning octave in cents.+tn_octave_cents :: Tuning -> T.Cents+tn_octave_cents = tn_as_cents . tn_octave_def++-- | Tuning octave as ratio cents.+tn_octave_ratio :: Double -> Tuning -> Rational+tn_octave_ratio epsilon = tn_as_ratio epsilon . tn_octave_def++-- | Divisions of octave.+--+-- > tn_divisions (tn_equal_temperament 12) == 12+tn_divisions :: Tuning -> Int+tn_divisions = either length length . tn_ratios_or_cents++-- | 'Maybe' exact ratios of 'Tuning', NOT including the octave.+tn_ratios :: Tuning -> Maybe [Rational]+tn_ratios = T.from_left . tn_ratios_or_cents++-- | Limit of JI tuning.+tn_limit :: Tuning -> Maybe Integer+tn_limit = fmap (maximum . map T.rational_prime_limit) . tn_ratios++-- | 'error'ing variant.+tn_ratios_err :: Tuning -> [Rational]+tn_ratios_err = fromMaybe (error "ratios") . tn_ratios++-- | Possibly inexact 'Cents' of tuning, NOT including the octave.+tn_cents :: Tuning -> [T.Cents]+tn_cents = either (map T.ratio_to_cents) id . tn_ratios_or_cents++-- | 'map' 'round' '.' 'cents'.+tn_cents_i :: Integral i => Tuning -> [i]+tn_cents_i = map round . tn_cents++-- | Variant of 'tn_cents' that includes octave at right.+tn_cents_octave :: Tuning -> [T.Cents]+tn_cents_octave t = tn_cents t ++ [tn_octave_cents t]++-- | 'tn_cents' / 100+tn_fmidi :: Tuning -> [Double]+tn_fmidi = map (* 0.01) . tn_cents++-- | Possibly inexact 'Approximate_Ratio's of tuning.+tn_approximate_ratios :: Tuning -> [T.Approximate_Ratio]+tn_approximate_ratios =+    either (map T.approximate_ratio) (map T.cents_to_fratio) .+    tn_ratios_or_cents++-- | Cyclic form, taking into consideration 'octave_ratio'.+tn_approximate_ratios_cyclic :: Tuning -> [T.Approximate_Ratio]+tn_approximate_ratios_cyclic t =+    let r = tn_approximate_ratios t+        m = T.cents_to_fratio (tn_octave_cents t)+        g = iterate (* m) 1+        f n = map (* n) r+    in concatMap f g++-- | Lookup function that allows both negative & multiple octave indices.+--+-- > :l Music.Theory.Tuning.DB.Werckmeister+-- > let map_zip f l = zip l (map f l)+-- > map_zip (tn_ratios_lookup werckmeister_vi) [-24 .. 24]+tn_ratios_lookup :: Tuning -> Int -> Maybe Rational+tn_ratios_lookup t n =+    let (o,pc) = n `divMod` tn_divisions t+        o_ratio = T.oct_diff_to_ratio (tn_octave_ratio tn_epsilon t) o+    in fmap (\r -> o_ratio * (r !! pc)) (tn_ratios t)++-- | Lookup function that allows both negative & multiple octave indices.+--+-- > map_zip (tn_approximate_ratios_lookup werckmeister_v) [-24 .. 24]+tn_approximate_ratios_lookup :: Tuning -> Int -> T.Approximate_Ratio+tn_approximate_ratios_lookup t n =+    let (o,pc) = n `divMod` tn_divisions t+        o_ratio = fromRational (T.oct_diff_to_ratio (tn_octave_ratio tn_epsilon t) o)+    in o_ratio * ((tn_approximate_ratios t) !! pc)++-- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents'+-- of 'Tuning'.+--+-- > :l Music.Theory.Tuning.DB.Werckmeister+-- > let r = [1,17/16,9/8,13/11,5/4,4/3,7/5,3/2,11/7,5/3,16/9,15/8]+-- > tn_reconstructed_ratios 1e-2 werckmeister_iii == Just r+tn_reconstructed_ratios :: Double -> Tuning -> Maybe [Rational]+tn_reconstructed_ratios epsilon =+    fmap (map (T.reconstructed_ratio epsilon)) .+    T.from_right .+    tn_ratios_or_cents++-- * Equal temperaments++-- | Make /n/ division equal temperament.+tn_equal_temperament :: Integral n => n -> Tuning+tn_equal_temperament n =+    let c = genericTake n [0,1200 / fromIntegral n ..]+    in Tuning (Right c) Nothing++-- | 12-tone equal temperament.+--+-- > tn_cents tn_equal_temperament_12 == [0,100..1100]+tn_equal_temperament_12 :: Tuning+tn_equal_temperament_12 = tn_equal_temperament (12::Int)++-- | 19-tone equal temperament.+--+-- > let c = [0,63,126,189,253,316,379,442,505,568,632,695,758,821,884,947,1011,1074,1137]+-- > tn_cents_i tn_equal_temperament_19 == c+tn_equal_temperament_19 :: Tuning+tn_equal_temperament_19 = tn_equal_temperament (19::Int)++-- | 31-tone equal temperament.+tn_equal_temperament_31 :: Tuning+tn_equal_temperament_31 = tn_equal_temperament (31::Int)++-- | 53-tone equal temperament.+tn_equal_temperament_53 :: Tuning+tn_equal_temperament_53 = tn_equal_temperament (53::Int)++-- | 72-tone equal temperament.+--+-- > let r = [0,17,33,50,67,83,100]+-- > take 7 (map round (tn_cents tn_equal_temperament_72)) == r+tn_equal_temperament_72 :: Tuning+tn_equal_temperament_72 = tn_equal_temperament (72::Int)++-- | 96-tone equal temperament.+tn_equal_temperament_96 :: Tuning+tn_equal_temperament_96 = tn_equal_temperament (96::Int)+
+ Music/Theory/Tuning/Wilson.hs view
@@ -0,0 +1,903 @@+-- | Erv Wilson, archives <http://anaphoria.com/wilson.html>+module Music.Theory.Tuning.Wilson where++import Control.Monad {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -}+import Safe {- safe -}+import System.FilePath {- filepath -}+import Text.Printf {- base -}++import qualified Music.Theory.Array.Text as T {- hmt -}+import qualified Music.Theory.Function as T {- hmt -}+import qualified Music.Theory.Graph.Dot as T {- hmt -}+import qualified Music.Theory.Graph.Type as T {- hmt -}+import qualified Music.Theory.Interval.Barlow_1987 as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Math.Convert as T {- hmt -}+import qualified Music.Theory.Math.OEIS as T {- hmt -}+import qualified Music.Theory.Math.Prime as T {- hmt -}+import qualified Music.Theory.Set.List as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.Scala as T {- hmt -}+import qualified Music.Theory.Tuple as T {- hmt -}++-- * GEOM (SEE "Data.CG.Minus.Plain")++type V2 n = (n,n)+v2_map :: (t -> u) -> V2 t -> V2 u+v2_map f (a,b) = (f a,f b)+v2_zip :: (a -> b -> c) -> V2 a -> V2 b -> V2 c+v2_zip f (i,j) (p,q) = (f i p,f j q)+v2_add :: Num n => V2 n -> V2 n -> V2 n+v2_add = v2_zip (+)+v2_sum :: Num n => [V2 n] -> V2 n+v2_sum = foldl v2_add (0,0)+v2_scale :: Num n => n -> V2 n -> V2 n+v2_scale n = v2_map (* n)++-- * PT SET++{- | Normalise set of points to lie in (-1,-1) - (1,1), scaling symetrically about (0,0)++> pt_set_normalise_sym [(40,0),(0,40),(13,11),(-8,4)] == [(1,0),(0,1),(0.325,0.275),(-0.2,0.1)]+> pt_set_normalise_sym [(-10,0),(1,10)] == [(-1,0),(0.1,1)]+-}+pt_set_normalise_sym :: (Fractional n,Ord n) => [V2 n] -> [V2 n]+pt_set_normalise_sym x = let z = maximum (map (uncurry max . T.bimap1 abs) x) in map (v2_scale (recip z)) x++-- * LATTICE CO-ORD++-- | /k/-unit co-ordinates for /k/-lattice.+type LC n = [V2 n]++-- | Erv Wilson standard lattice, unit co-ordinates for 5-dimensions, ie. [3,5,7,11,13]+--+-- <http://anaphoria.com/wilsontreasure.html>+ew_lc_std :: Num n => LC n+ew_lc_std = [(20,0),(0,20),(4,3),(-3,4),(-1,2)]++-- | Kraig Grady standard lattice, unit co-ordinates for 5-dimensions, ie. [3,5,7,11,13]+--+-- <http://anaphoria.com/wilsontreasure.html>+kg_lc_std :: Num n => LC n+kg_lc_std = [(40,0),(0,40),(13,11),(-14,18),(-8,4)]++-- | Erv Wilson tetradic lattice, used especially when working with hexanies or 7 limit tunings+--+-- <http://anaphoria.com/wilsontreasure.html>+ew_lc_tetradic :: Num n => LC n+ew_lc_tetradic = [(-4,-2),(6,1),(5,-2)]++-- | Resolve POS against LC to V2+lc_pos_to_pt :: (Fractional n, Ord n) => LC n -> POS -> V2 n+lc_pos_to_pt lc x = v2_sum (zipWith (v2_scale . fromIntegral) x (pt_set_normalise_sym lc))++-- * LAT++-- | A discrete /k/-lattice is described by a sequence of /k/-factors.+--   LAT values are ordinarily though not necessarily primes.+type LAT = [Integer]++-- | Positions in a /k/-lattice are given as a /k/-list of steps.+type POS = [Int]++-- | White-space pretty printer for POS.+--+-- > pos_pp_ws [0,-2,1] == "  0 -2  1"+pos_pp_ws :: POS -> String+pos_pp_ws = let f x = printf "%3d" x in concatMap f++-- | Given LAT [X,Y,Z..] and POS [x,y,z..], calculate the indicated ratio.+--+-- > lat_res [3,5] [-5,2] == (5 * 5) / (3 * 3 * 3 * 3 * 3)+lat_res :: LAT -> POS -> Rational+lat_res p q =+  let f i j = case compare j 0 of+                GT -> (i ^ T.int_to_integer j) % 1+                EQ -> 1+                LT -> 1 % (i ^ abs (T.int_to_integer j))+  in product (zipWith f p q)++-- * RAT (n,d)++-- | Ratio given as (/n/,/d/)+type RAT = (Integer,Integer)++-- | Remove all octaves from /n/ and /d/.+rat_rem_oct :: RAT -> RAT+rat_rem_oct = T.bimap1 (product . filter (/= 2)) . T.rat_prime_factors++-- | Lift 'RAT' function to 'Rational'.+rat_lift_1 :: (RAT -> RAT) -> Rational -> Rational+rat_lift_1 f = uncurry (%) . f . T.rational_nd++rat_to_ratio :: RAT -> Rational+rat_to_ratio (n,d) = n % d++-- | Mediant, ie. n1+n2/d1+d2+--+-- > rat_mediant (0,1) (1,2) == (1,3)+rat_mediant :: RAT -> RAT -> RAT+rat_mediant (n1,d1) (n2,d2) = (n1 + n2,d1 + d2)++rat_pp :: RAT -> String+rat_pp (n,d) = concat [show n,"/",show d]++-- * Rational++-- | Lifted 'rat_rem_oct'.+--+-- > map ew_r_rem_oct [256/243,7/5,1/7] == [1/243,7/5,1/7]+r_rem_oct :: Rational -> Rational+r_rem_oct = rat_lift_1 rat_rem_oct++-- | Assert that /n/ is in [1,2).+r_verify_oct :: Rational -> Rational+r_verify_oct i = if i >= 1 && i < 2 then i else error (show ("r_verify_oct?",i))++-- | Find limit of set of ratios, ie. largest factor in either numerator or denominator.+--+-- > r_seq_limit [1] == 1+r_seq_limit :: [Rational] -> Integer+r_seq_limit = maximum . map T.rational_prime_limit++-- * Table++-- > map (rat_fact_lm 11) [3,5,7,11] == [[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]+rat_fact_lm :: Integer -> Rational -> POS+rat_fact_lm lm = tail . T.rat_prime_factors_t (fromMaybe 1 (T.prime_k lm) + 1) . T.rational_nd++tbl_txt :: Integer -> [Rational] -> [[String]]+tbl_txt lm_z rs =+  let lm = r_seq_limit rs+      scl = map (rat_fact_lm lm) rs+      cs = map (T.ratio_to_cents . T.fold_ratio_to_octave_err) rs+      hs = map (T.harmonicity_r T.barlow) rs :: [Double]+      f (k,x,r,c,h) = [show k+                      ,if lm <= lm_z then pos_pp_ws x else "..."+                      ,T.ratio_pp r+                      ,T.real_pp 2 c+                      ,T.real_pp_unicode 2 h]+  in map (intersperse "=" . f) (zip5 [0::Int ..] scl rs cs hs)++-- > tbl_wr [1,7/6,5/4,4/3,3/2]+tbl_wr :: [Rational] -> IO ()+tbl_wr = putStr . unlines . T.table_pp (False,True,False," ",False) . tbl_txt 31++-- * Graph++-- | (maybe-lc,gr-attr,vertex-pp)+type EW_GR_OPT = (Maybe (LC Rational),[T.DOT_META_ATTR],Rational -> String)++ew_gr_opt_pos :: EW_GR_OPT -> Bool+ew_gr_opt_pos (lc_m,_,_) = isJust lc_m++ew_gr_r_pos :: LC Rational -> Rational -> T.DOT_ATTR+ew_gr_r_pos lc =+  let f m (x,y) = (m * x,m * y)+  in T.node_pos_attr . f 160 . lc_pos_to_pt lc . Safe.tailDef [] . T.rational_prime_factors_l++ew_gr_udot :: EW_GR_OPT -> T.LBL Rational () -> [String]+ew_gr_udot (lc_m,attr,v_pp) =+  let (e,p_f) = case lc_m of+                  Nothing -> ("sfdp",const Nothing)+                  Just lc -> ("neato",Just . ew_gr_r_pos lc)+  in T.lbl_to_udot+     ([("graph:layout",e),("node:shape","plain")] ++ attr) -- ("graph:K","0.6") ("edge:len","1.0")+     (\(_,v) -> T.mcons (p_f v) [("label",v_pp v)]+     ,\_ -> [])++ew_gr_udot_wr :: EW_GR_OPT -> FilePath -> T.LBL Rational () -> IO ()+ew_gr_udot_wr opt fn = writeFile fn . unlines . ew_gr_udot opt++ew_gr_udot_wr_svg :: EW_GR_OPT -> FilePath -> T.LBL Rational () -> IO ()+ew_gr_udot_wr_svg opt fn gr = do+  ew_gr_udot_wr opt fn gr+  void (T.dot_to_svg (if ew_gr_opt_pos opt then ["-n"] else []) fn (replaceExtension fn "svg"))++-- * ZIG-ZAG++zz_seq_1 :: (Eq n,Num n) => Int -> (n,n) -> (n,n) -> [(n,n)]+zz_seq_1 k (p,q) (n,d) = if k == 0 then [(n,d)] else (n,d) : zz_seq_1 (k - 1) (p,q) (n+p,d+q)++-- > zz_next 3 [(0,1),(1,1)] == [(1,1),(1,2),(1,3),(1,4)]+zz_next :: (Eq n, Num n) => Int -> [(n,n)] -> [(n,n)]+zz_next k p =+  case reverse p of+    i:j:_ -> zz_seq_1 k j i+    _ -> error "zz_next?"++zz_recur :: (Eq n, Num n) => [Int] -> [(n,n)] -> [[(n,n)]]+zz_recur k_seq p =+  case k_seq of+    [] -> []+    k:k_rem -> let r = zz_next k p in r : zz_recur k_rem r++-- > zz_seq [3,9,2,2,4,6,2,1,1,3]+-- > zz_seq [2,4,2,158]+-- > zz_seq [1,1,4,2,1,3,1,6,2]+zz_seq :: (Eq n, Num n) => [Int] -> [[(n, n)]]+zz_seq k_seq = zz_recur k_seq [(0,1),(1,1)]++-- * MOS++-- > gen_coprime 12 == [1,5]+-- > gen_coprime 49 == [1..24] \\ [7,14,21]+gen_coprime :: Integral a => a -> [a]+gen_coprime x = filter (\y -> gcd y x == 1) [1 .. (x `div` 2)]++-- > mos_2 12 5 == (5,7)+mos_2 :: Num n => n -> n -> (n,n)+mos_2 p g = (g,p - g)++-- | Divide MOS, keeps retained value on same side+--+-- > mos_step (5,7) == (5,2)+-- > mos_step (5,2) == (3,2)+-- > mos_step (3,2) == (1,2)+mos_step :: (Ord a, Num a) => (a, a) -> (a, a)+mos_step (i,j) = if i < j then (i,j - i) else (i - j,j)++-- > mos_unfold (5,7)  == [(5,7),(5,2),(3,2),(1,2)]+-- > mos_unfold (41,17) == [(41,17),(24,17),(7,17),(7,10),(7,3),(4,3),(1,3),(1,2)]+mos_unfold :: (Ord b, Num b) => (b, b) -> [(b, b)]+mos_unfold x =+  let y = mos_step x+  in if T.t2_sum y == 3 then [x,y] else x : mos_unfold y++mos_verify :: Integral a => a -> a -> Bool+mos_verify p g =+  let x = if g > (p `div` 2) then p `mod` g else g+  in x `elem` gen_coprime p++-- > mos 12 5 == [(5,7),(5,2),(3,2),(1,2)]+mos :: (Ord b, Integral b) => b -> b -> [(b, b)]+mos p g = if mos_verify p g then mos_unfold (mos_2 p g) else error "mos?"++-- > mos_seq 12 5 == [[5,7],[5,5,2],[3,2,3,2,2],[1,2,2,1,2,2,2]]+-- > mos_seq 41 17 !! 4 == [3,3,4,3,4,3,3,4,3,4,3,4]+-- > map length (mos_seq 49 27) == [2,3,5,7,9,11,20,29]+mos_seq :: (Ord b, Integral b) => b -> b -> [[b]]+mos_seq p g =+  let step_f (i,j) = concatMap (\x -> if x == i + j then [i,j] else [x])+      recur_f x l = if null x then [l] else l : recur_f (tail x) (step_f (head x) l)+      (i0,j0):r = mos p g+  in recur_f r [i0,j0]++mos_cell_pp :: (Integral i,Show i) => i -> String+mos_cell_pp x = let s = show x in s ++ genericReplicate (x - genericLength s) '-'++mos_row_pp :: (Integral i,Show i) => [i] -> String+mos_row_pp = concatMap mos_cell_pp++mos_tbl_pp :: (Integral i,Show i) => [[i]] -> [String]+mos_tbl_pp = map mos_row_pp++-- > mos_tbl_wr (mos_seq 49 27)+mos_tbl_wr :: (Integral i,Show i) => [[i]] -> IO ()+mos_tbl_wr = putStrLn . unlines . mos_tbl_pp++-- * MOS/LOG++mos_recip_seq :: Double -> [(Int,Double)]+mos_recip_seq x = let y = truncate x in (y,x) : mos_recip_seq (recip (x - fromIntegral y))++-- > take 3 (mos_log (5/4)) == [(3,3.10628371950539),(9,9.408778735385603),(2,2.4463112031908785)]+mos_log :: Double -> [(Int,Double)]+mos_log r = mos_recip_seq (recip (logBase 2 r))++-- > take 9 (mos_log_kseq 1.465571232) == [1,1,4,2,1,3,1,6,2]+mos_log_kseq :: Double -> [Int]+mos_log_kseq = map fst . mos_log++-- * STERN-BROCOT TREE++data SBT_DIV = NIL | LHS | RHS deriving (Show)+type SBT_NODE = (SBT_DIV,RAT,RAT,RAT)++sbt_step :: SBT_NODE -> [SBT_NODE]+sbt_step (_,l,m,r) = [(LHS,l,rat_mediant l m, m),(RHS,m,rat_mediant m r,r)]++-- sbt = stern-brocot tree+sbt_root :: SBT_NODE+sbt_root = (NIL,(0,1),(1,1),(1,0))++sbt_half :: SBT_NODE+sbt_half = (NIL,(0,1),(1,2),(1,1))++-- > sbt_from sbt_root+sbt_from :: SBT_NODE -> [[SBT_NODE]]+sbt_from = iterate (concatMap sbt_step) . return++sbt_k_from :: Int -> SBT_NODE -> [[SBT_NODE]]+sbt_k_from k = take k . sbt_from++sbt_node_to_edge :: SBT_NODE -> String+sbt_node_to_edge (dv,l,m,r) =+  let edge_pp p q = printf "\"%s\" -- \"%s\"" (rat_pp p) (rat_pp q)+  in case dv of+       NIL -> ""+       LHS -> edge_pp r m+       RHS -> edge_pp l m++sbt_node_elem :: SBT_NODE -> [RAT]+sbt_node_elem (dv,l,m,r) =+  case dv of+    NIL -> [l,m,r]+    _ -> [m]++sbt_dot :: [SBT_NODE] -> [String]+sbt_dot n =+  let e = map sbt_node_to_edge n+  in concat [["graph {","node [shape=plain]"],e,["}"]]++-- * M-GEN++(^.) :: Rational -> Int -> Rational+(^.) = (^)++r_normalise :: [Rational] -> [Rational]+r_normalise = nub . sortOn T.fold_ratio_to_octave_err++-- | (ratio,multiplier,steps)+type M_GEN = (Rational,Rational,Int)++m_gen_unfold :: M_GEN -> [Rational]+m_gen_unfold (r,m,n) = take n (iterate (* m) r)++m_gen_to_r :: [M_GEN] -> [Rational]+m_gen_to_r = r_normalise . concatMap m_gen_unfold++-- * M3-GEN++-- | (ratio,M3-steps)+type M3_GEN = (Rational,Int)++m3_to_m :: M3_GEN -> M_GEN+m3_to_m (r,n) = (r,3,n)++-- > map m3_gen_unfold [(3,4),(21/9,4),(15/9,4),(35/9,3),(21/5,4),(27/5,3)]+m3_gen_unfold :: M3_GEN -> [Rational]+m3_gen_unfold = m_gen_unfold . m3_to_m++m3_gen_to_r :: [M3_GEN] -> [Rational]+m3_gen_to_r = r_normalise . concatMap m3_gen_unfold++-- * SCALA++r_to_scale :: String -> String -> [Rational] -> T.Scale+r_to_scale nm dsc r =+  let r' = map T.fold_ratio_to_octave_err (tail r) ++ [2]+  in if r !! 0 /= 1 || not (T.is_ascending r')+     then error "r_to_scale?"+     else (nm,dsc,length r,map Right r')++ew_scl_find_r :: [Rational] -> IO [String]+ew_scl_find_r r =+  let set_eq x y = sort x == sort y+  in if head r /= 1+     then error "ew_scl_find_r?"+     else fmap (map T.scale_name) (T.scl_find_ji set_eq (map T.fold_ratio_to_octave_err r ++ [2]))++-- * <http://anaphoria.com/1-3-5-7-9Genus.pdf>++ew_1357_3_gen :: [M3_GEN]+ew_1357_3_gen = [(3,4),(21/9,4),(15/9,4),(35/9,3),(21/5,4),(27/5,3)]++{- | P.3 7-limit {SCALA=NIL}++> ew_scl_find_r (1 : ew_1357_3_r)+-}+ew_1357_3_r :: [Rational]+ew_1357_3_r = r_normalise (concatMap m3_gen_unfold ew_1357_3_gen)++ew_1357_3_scl :: T.Scale+ew_1357_3_scl = r_to_scale "ew_1357_3" "EW, 1-3-5-7-9Genus.pdf, P.3" (1 : ew_1357_3_r)++-- * <http://anaphoria.com/earlylattices12.pdf>++{- | P.7 11-limit {SCALA=NIL}++> ew_scl_find_r ew_el12_7_r+-}+ew_el12_7_r :: [Rational]+ew_el12_7_r = [1,5/(7*11),1/7,7*11,7*11*11/5,11,5/7,1/11,7*11*11,1/(7*11),11*11,7*11/5]++ew_el12_7_scl :: T.Scale+ew_el12_7_scl = r_to_scale "ew_el12_7" "EW, earlylattices12.pdf, P.7" ew_el12_7_r++{- | P.9 7-limit {SCALA=wilson_class}++> ew_scl_find_r ew_el12_9_r+-}+ew_el12_9_r :: [Rational]+ew_el12_9_r = [1,5*5/3,7/(5*5),7/3,5,1/3,7/5,5*7/3,1/5,5/3,7,7/(3*5)]++--ew_el12_9_scl :: T.Scale+--ew_el12_9_scl = r_to_scale "ew_el12_9" "EW, earlylattices12.pdf, P.9" ew_el12_9_r++{- | P.12 11-limit {SCALA=NIL}++> ew_scl_find_r ew_el12_12_r+-}+ew_el12_12_r :: [Rational]+ew_el12_12_r = [1,3*3*5/11,3/11,7/3,5,7/11,3*5/11,5*7/3,7/(3*3),5*7/11,7/(3*11),3*5]++ew_el12_12_scl :: T.Scale+ew_el12_12_scl = r_to_scale "ew_el12_12" "EW, earlylattices12.pdf, P.12" ew_el12_12_r++-- * <http://anaphoria.com/earlylattices22.pdf>++{- | P.2 11-limit {SCALA=wilson_l4}++> ew_scl_find_r ew_el22_2_r+-}+ew_el22_2_r :: [Rational]+ew_el22_2_r =+  [1,7*7/3,3*7/5,5/(3*3),1/7,7/3,3/5,5,5*7/(3*3*3),1/3,7*7/(3*3)+  ,7/5,5*7/3,3,7/(3*3),1/5,5/3,3/7,7,3*3/5,7/(3*5),5*7/(3*3)]++{- | P.3 11-limit {SCALA=wilson_l5}++> ew_scl_find_r ew_el22_3_r+-}+ew_el22_3_r :: [Rational]+ew_el22_3_r =+  [1,7*7/3,7*11/(3*3),3/11,1/7,7/3,3/5,5,7/11,1/3,7*7/(3*3)+  ,7/5,5*7/3,3,7/(3*3),1/5,5/3,3/7,7,11/3,7/(3*5),5*7/(3*3)]++{- | P.4 11-limit {SCALA=wilson_l3}++> ew_scl_find_r ew_el22_4_r+-}+ew_el22_4_r :: [Rational]+ew_el22_4_r =+  [1,3*11,3*7/5,5*7,3*3,7/3,3/5,5,7/11,3*7,11+  ,7/5,5*7/3,3,7/(3*3),1/5,3*5*7,3*3*3,7,3*3/5,3*5,3*7/11]++{- | P.5 11-limit {SCALA=wilson_l1}++> ew_scl_find_r ew_el22_5_r+-}+ew_el22_5_r :: [Rational]+ew_el22_5_r =+  [1,3*11,3*7/5,5*7,3*3,7/3,7*11,5,3*5*11,3*7,11+  ,7/5,3*7*11/5,3,3*3*11,7*11/3,3*11/5,5*11,7,3*7*11,3*5,7*11/5]++{- | P.6 11-limit {SCALA=wilson_l2}++> ew_scl_find_r ew_el22_6_r+-}+ew_el22_6_r :: [Rational]+ew_el22_6_r =+  [1,7*7/3,7*11/(3*3),11/5,3*3,7/3,7*11,5,7*11/(3*5),1/3,11+  ,7*11/(3*3*3),5*7/3,3,11/7,7*11/3,5/3,7*11/(3*3*5),7,11/3,3*5,7*11/5]++-- * <http://anaphoria.com/diamond.pdf>++ew_diamond_mk :: [Integer] -> [Rational]+ew_diamond_mk u = r_normalise [x % y | x <- u, y <- u]++-- > m3_gen_to_r ew_diamond_12_gen == ew_diamond_12_r+ew_diamond_12_gen :: [M3_GEN]+ew_diamond_12_gen =+  [(1/(3^.2),5),(5/(3^.2),3),(7/(3^.2),3),(11/(3^.2),3)+  ,(1/5,3),(1/7,3),(1/11,3)+  ,(5/7,1),(5/11,1),(7/5,1),(7/11,1),(11/5,1),(11/7,1)]++{- | P.7 & P.12 11-limit {SCALA=partch_29}++1,3,5,7,9,11 diamond++> ew_scl_find_r ew_diamond_12_r -- partch_29+-}+ew_diamond_12_r :: [Rational]+ew_diamond_12_r = ew_diamond_mk [1,3,5,7,9,11]++{- | P.10 & P.13 13-limit {SCALA=novaro15}++1,3,5,7,9,11,13,15 diamond++> ew_scl_find_r ew_diamond_13_r -- novaro15+-}+ew_diamond_13_r :: [Rational]+ew_diamond_13_r = ew_diamond_mk [1,3,5,7,9,11,13,15]++-- * <http://anaphoria.com/hel.pdf>++hel_r_asc :: (Integer,Integer) -> [Rational]+hel_r_asc (n,d) = n%d : hel_r_asc (n+1,d+1)++type HEL = ([Rational],[Rational])++-- | P.6+hel_1_i :: HEL+hel_1_i =+  let i = take 6 (hel_r_asc (7,6))+  in (take 5 i,take 5 (T.rotate_left 2 i))++-- | P.6+hel_2_i :: HEL+hel_2_i =+  let i = take 10 (hel_r_asc (9,8))+  in (take 8 (T.rotate_left 3 (tail i))+     ,take 7 i)++-- | P.10+hel_3_i :: HEL+hel_3_i =+  let i = take 16 (hel_r_asc (15,14))+  in (take 13 (T.rotate_left 6 (take 14 i)),take 14 (tail i))++hel_r :: HEL -> [[Rational]]+hel_r (p,q) =+  let i_to_r = scanl (*) 1+  in [i_to_r p,i_to_r q,r_normalise (concat [i_to_r p,i_to_r q])]++{- | P.12 {SCALA=NIL}++22-tone 23-limit Evangalina tuning (2001)++> ew_scl_find_r ew_hel_12_r+-}+ew_hel_12_r :: [Rational]+ew_hel_12_r =+  [1,3*3*3*5,13/3,5/(3*3),3*3,7/3,11/(3*3),5,3*3*3*3,1/3,11+  ,3*3*5,17/3,3,3*3*3*3*5,13,5/3,3*3*3,7,11/3,3*5,23/3]++ew_hel_12_scl :: T.Scale+ew_hel_12_scl = r_to_scale "ew_hel_12" "EW, hel.pdf, P.12" ew_hel_12_r++-- * <http://anaphoria.com/HexanyStellatesExpansions.pdf>++-- > she_div "ABCD" == [["BCD","A"],["ACD","B"],["ABD","C"],["ABC","D"]]+she_div :: Eq a => [a] -> [[[a]]]+she_div x =+  let f = (== [1,length x - 1]) . sort . map length+  in map (reverse . sortOn length) (filter f (T.partitions x))++-- > she_div_r [1,3,5,7] == [105,35/3,21/5,15/7]+she_div_r :: [Rational] -> [Rational]+she_div_r =+  let f x =+        case x of+          [[a,b,c],[d]] -> (a * b * c) / d+          _ -> error "she_div?"+  in map f . she_div++-- > she_mul_r [1,3,5,7] == [1,3,5,7,9,15,21,25,35,49]+she_mul_r :: [Rational] -> [Rational]+she_mul_r r = [(x * y) | x <- r,y <- r,x <= y]++{- | she = Stellate Hexany Expansions, P.10 {SCALA=stelhex1,stelhex2,stelhex5,stelhex6}++> she [1,3,5,7] == [1,21/20,15/14,35/32,9/8,5/4,21/16,35/24,3/2,49/32,25/16,105/64,7/4,15/8]+> mapM (ew_scl_find_r . she) [[1,3,5,7],[1,3,5,9],[1,3,7,9],[1,3,5,11]]+> ew_scl_find_r (she [1,(5*7)/(3*3),1/(3 * 5),1/3]) -- NIL+-}+she :: [Rational] -> [Rational]+she r = nub (sort (map T.fold_ratio_to_octave_err (she_mul_r r ++ she_div_r r)))++-- * <http://anaphoria.com/meru.pdf>++-- > map (every_nth "abcdef") [1..3] == ["abcdef","ace","ad"]+every_nth :: [t] -> Int -> [t]+every_nth l k =+  case l of+    [] -> []+    x:_ -> x : every_nth (drop k l) k++meru :: Num n => [[n]]+meru =+  let f xs = zipWith (+) ([0] ++ xs) (xs ++ [0])+  in iterate f [1]++-- > meru_k 13+meru_k :: Num n => Int -> [[n]]+meru_k k = take k meru++-- > map (sum . meru_1) [1 .. 13] == [1,1,2,3,5,8,13,21,34,55,89,144,233]+meru_1 :: Num n => Int -> [n]+meru_1 k = zipWith (\x l -> atDef 0 l x) [0..] (reverse (meru_k k))++-- > take 13 meru_1_direct == [1,1,2,3,5,8,13,21,34,55,89,144,233]+meru_1_direct :: Num n => [n]+meru_1_direct = tail T.a000045++-- | Meru 2 = META-PELOG+--+-- > map (sum . meru_2) [1 .. 14] == [1,1,1,2,3,4,6,9,13,19,28,41,60,88]+meru_2 :: Num n => Int -> [n]+meru_2 k = zipWith (\x l -> atDef 0 l x) [0..] (every_nth (reverse (meru_k k)) 2)++-- > take 14 meru_2_direct == [1,1,1,2,3,4,6,9,13,19,28,41,60,88]+meru_2_direct :: Num n => [n]+meru_2_direct = T.a000930++-- | meru_3 = META-SLENDRO+meru_3 :: Num n => Int -> [[n]]+meru_3 k =+  let f t = zipWith (\x l -> atDef 0 l x) [0,2..] t+      t0 = reverse (meru_k k)+      t1 = map tail t0+  in [f t0,f t1]++-- > map sum (meru_3_seq 13) == [1,0,1,1,1,2,2,3,4,5,7,9,12,16,21,28,37,49,65,86,114,151,200,265,351,465]+meru_3_seq :: Num n => Int -> [[n]]+meru_3_seq k = concatMap meru_3 [1 .. k]++-- > take 26 meru_3_direct == [1,0,1,1,1,2,2,3,4,5,7,9,12,16,21,28,37,49,65,86,114,151,200,265,351,465]+meru_3_direct :: Num n => [n]+meru_3_direct = drop 3 T.a000931++-- > map (sum . meru_4) [1 .. 13] == [1,1,1,1,2,3,4,5,7,10,14,19,26]+meru_4 :: Num n => Int -> [n]+meru_4 k = zipWith (\x l -> atDef 0 l x) [0..] (every_nth (reverse (meru_k k)) 3)++-- > take 31 meru_4_direct == map (sum . meru_4) [1 .. 31]+meru_4_direct :: Num n => [n]+meru_4_direct = tail T.a003269++-- > map meru_5 [1..4]+meru_5 :: Num n => Int -> [[n]]+meru_5 k =+  let f t = zipWith (\x l -> atDef 0 l x) [0,3..] t+      t0 = reverse (meru_k k)+  in map (\n -> f (map (drop n) t0)) [0 .. 2]++-- > map sum (meru_5_seq 13)+meru_5_seq :: Num n => Int -> [[n]]+meru_5_seq k = concatMap meru_5 [1 .. k]++-- > take 39 meru_5_direct == map sum (meru_5_seq 13)+meru_5_direct :: Num n => [n]+meru_5_direct = T.a017817++-- > map (sum . meru_6) [1 .. 21] == [1,1,1,1,1,2,3,4,5,6,8,11,15,20,26,34,45,60,80,106,140]+meru_6 :: Num n => Int -> [n]+meru_6 k = zipWith (\x l -> atDef 0 l x) [0..] (every_nth (reverse (meru_k k)) 4)++-- > take 21 meru_6_direct == map (sum . meru_6) [1 .. 21]+meru_6_direct :: Num n => [n]+meru_6_direct = T.a003520++-- > take 26 meru_7_direct == [0,1,0,1,0,1,1,1,2,1,3,2,4,4,5,7,7,11,11,16,18,23,29,34,45,52]+meru_7_direct :: Num n => [n]+meru_7_direct = T.a001687++-- * <http://anaphoria.com/mos.pdf>++{- | P.13, tanabe {SCALA=chin_7}++> ew_scl_find_r ew_mos_13_tanabe_r+-}+ew_mos_13_tanabe_r :: [Rational]+ew_mos_13_tanabe_r = [1,9/8,81/64,4/3,3/2,27/16,243/128]++-- * <http://anaphoria.com/novavotreediamond.pdf> (Novaro)++ew_novarotreediamond_1 :: ([[Rational]],[[Rational]])+ew_novarotreediamond_1 =+  let rem_oct x = if last x /= 2 then error "rem_oct?" else T.drop_last x+      add_oct x = if last x >= 2 then error "add_oct?" else x ++ [2]+      r_to_i = T.d_dx_by (/) . add_oct+      i_to_r = rem_oct . scanl (*) 1+      r_0 = [1,5/4,4/3,3/2,5/3,7/4]+      i_0 = r_to_i r_0+      i = T.rotations i_0+  in (i,map i_to_r i)++{- | P.1 {SCALA=NIL}++23-tone 7-limit (2004)++> ew_scl_find_r ew_novarotreediamond_1_r+-}+ew_novarotreediamond_1_r :: [Rational]+ew_novarotreediamond_1_r = r_normalise (concat (snd ew_novarotreediamond_1))++ew_novarotreediamond_1_scl :: T.Scale+ew_novarotreediamond_1_scl = r_to_scale "ew_novarotreediamond_1" "EW, novavotreediamond.pdf, P.1" ew_novarotreediamond_1_r++-- * <http://anaphoria.com/Pelogflute.pdf>++{- | P.2 {SCALA=NIL}++9-tone Pelog cycle (1988)++> ew_scl_find_r ew_pelogFlute_2+-}+ew_Pelogflute_2_r :: Fractional n => [n]+ew_Pelogflute_2_r = [1,16/15,64/55,5/4,4/3,16/11,8/5,128/75,20/11]++ew_Pelogflute_2_scl :: T.Scale+ew_Pelogflute_2_scl = r_to_scale "ew_Pelogflute_2" "EW, Pelogflute.pdf, P.2" ew_Pelogflute_2_r+++-- * <http://anaphoria.com/xen1.pdf>++-- | P.9, Fig. 3+xen1_fig3 :: (SBT_NODE,Int)+xen1_fig3 = ((NIL,(1,3),(2,5),(1,2)),5)++-- | P.9, Fig. 4+xen1_fig4 :: (SBT_NODE,Int)+xen1_fig4 = ((NIL,(2,5),(5,12),(3,7)),5)++-- * <http://anaphoria.com/xen3b.pdf>++-- | P.3 Turkisk Baglama Scale {11-limit, SCALA=NIL}+ew_xen3b_3_gen :: [(Rational,Int)]+ew_xen3b_3_gen = [(1/(3^.6),12),(1/11,2),(5/3,3)]++ew_xen3b_3_r :: [Rational]+ew_xen3b_3_r = m3_gen_to_r ew_xen3b_3_gen++ew_xen3b_3_scl :: T.Scale+ew_xen3b_3_scl = r_to_scale "ew_xen3b_3" "EW, xen3b.pdf, P.3" ew_xen3b_3_r++-- > map length xen3b_9_i == [5,7,12,19,31]+xen3b_9_i :: [[Rational]]+xen3b_9_i =+  [[6/5,                                             10/9,                          9/8,                           6/5,                                             10/9]+  ,[16/15,9/8,                                       10/9,                          9/8,                           16/15,9/8,                                       10/9]+  ,[16/15,135/128,16/15,                             25/24,16/15,                   16/15,135/128,                 16/15,135/128,16/15,                             25/24,16/15]+  ,[28/27,36/35,135/128,28/27,36/35,                 25/24,28/27,36/35,             28/27,36/35,135/128,           28/27,36/35,135/128,28/27,36/35,                 25/24,28/27,36/35]+  ,[64/63,49/48,36/35,45/44,33/32,64/63,49/48,36/35, 45/44,55/54,64/63,49/48,36/35, 64/63,49/48,36/35,45/44,33/32, 64/63,49/48,36/35,45/44,33/32,64/63,49/48,36/35, 45/44,55/54,64/63,49/48,36/35]]++{- | P.9 {SCALA 5=nil 7=ptolemy_idiat 12=nil 19=wilson2 31=wilson_31}++> mapM ew_scl_find_r xen3b_9_r+-}+xen3b_9_r :: [[Rational]]+xen3b_9_r = map (T.drop_last . scanl (*) 1) xen3b_9_i++-- > map length xen3b_13_i == [5,7,12,17,22]+xen3b_13_i :: [[Rational]]+xen3b_13_i =+  [[7/6,                           8/7,                     9/8,                     7/6,                           8/7]+  ,[28/27,9/8,                     8/7,                     9/8,                     28/27,9/8,                     8/7]+  ,[28/27,243/224,28/27,           10/9,36/35,              28/27,243/224,           28/27,243/224,28/27,           10/9,36/35]+  ,[28/27,36/35,135/128,28/27,     36/35,175/162,36/35,     28/27,36/35,135/128,     28/27,36/35,135/128,28/27,     36/35,175/162,36/35]+  ,[28/27,36/35,25/24,81/80,28/27, 36/35,25/24,28/27,36/35, 28/27,36/35,25/24,81/80, 28/27,36/35,25/24,81/80,28/27, 36/35,25/24,28/27,36/35]]++-- | P.13 {SCALA 5=slendro5_2 7=ptolemy_diat2 12=nil 17=nil 22=wilson7_4}+xen3b_13_r :: [[Rational]]+xen3b_13_r = map (T.drop_last . scanl (*) 1) xen3b_13_i++-- * <http://anaphoria.com/xen3bappendix.pdf>++{- | PP.1-2 {SCALA: 22=wilson7_4}++17,31,41 lattices from XEN3B (1975)+-}+ew_xen3b_apx_gen :: [(Int,[M3_GEN])]+ew_xen3b_apx_gen =+  [(17,[(1/729,12)+       ,(5/3,3)+       ,(11,2)])+  ,(31,[(1/3,5)+       ,(5,2),(1/(5*(3^.2)),5)+       ,(7/(3^.4),5),(1/(7*(3^.4)),5)+       ,(1/11,5)+       ,((1/3)*(1/7)*5,2)+       ,((1/(7*(3^.3))) * 5,2)])+  ,(41,[(1/(3^.6),12)+       ,(5/(3^.3),5),(1/(5*(3^.2)),5)+       ,(7/(3^.4),7),(1/(7*(3^.3)),7)+       ,(11,5)])+  ,(22,[(1/3,5)+       ,(5/(3^.3),5),(1/(5*(3^.2)),5)+       ,(7/(3^.4),5)+       ,(7/(3^.3)*5,2)])]++ew_xen3b_apx_r :: [(Int,[Rational])]+ew_xen3b_apx_r =+  let f (k,g) = (k,r_normalise (concatMap m3_gen_unfold g))+  in map f ew_xen3b_apx_gen++-- * <http://anaphoria.com/xen456.pdf>++ew_xen456_7_gen :: [M3_GEN]+ew_xen456_7_gen = [(25/24,4),(5/3,4),(4/3,4),(16/15,4),(32/25,3)]++{- P.7 {SCALA=wilson1}++19-tone "A Scale for Scott" (1976)++> L.ew_find_scl_name ew_xen456_7_r -- wilson1+-}+ew_xen456_7_r :: [Rational]+ew_xen456_7_r = m3_gen_to_r ew_xen456_7_gen++ew_xen456_9_gen :: [M3_GEN]+ew_xen456_9_gen =+  [(1/(3^.3),4)+  ,(1/(5*(3^.2)),3)+  ,(1/(7*3),3)+  ,(1/11,3)+  ,(5/(11*3),4)+  ,(7/11,2)]++{- | P.9 {SCALA=NIL}++19-tone scale for the Clavichord-19 (1976)++> ew_scl_find_r ew_xen456_9_r++> import qualified Music.Theory.List as T {- hmt -}+> T.scl_find_ji T.is_subset ew_xen456_9_r -- NIL+-}+ew_xen456_9_r :: [Rational]+ew_xen456_9_r = m3_gen_to_r ew_xen456_9_gen++ew_xen456_9_scl :: T.Scale+ew_xen456_9_scl = r_to_scale "ew_xen456_9" "EW, xen456.pdf, P.9" ew_xen456_9_r++-- * GEMS++{- | <http://wilsonarchives.blogspot.com/2010/10/scale-for-rod-poole.html>++13-limit 22-tone scale {SCALA=nil}++> ew_scl_find_r ew_poole_r+-}+ew_poole_r :: [Rational]+ew_poole_r =+  [1,11*3,7*3/5,13/3,3*3,7/3,11/(3*3),5,7/11,1/3+  ,11,7/5,13/(3*3),3,7/(3*3),11/(3*3*3),5/3,3*3*3,7,11/3,5*3,7*3/11]++ew_poole_scl :: T.Scale+ew_poole_scl = r_to_scale "ew_poole" "EW, 2010/10/scale-for-rod-poole.html" ew_poole_r++{- | <http://wilsonarchives.blogspot.com/2014/05/an-11-limit-centaur-implied-in-wilson.html>++11-limit 17-tone scale {SCALA=wilcent17}++> ew_scl_find_r ew_centaur17_r+-}+ew_centaur17_r :: [Rational]+ew_centaur17_r = [1,11/(3*7),11/5,3*3,7/3,11/(3*3),5,1/3,11,11/(3*5),3,11/7,11/(3*3*3),5/3,7,11/3,3*5]++{- | <http://wilsonarchives.blogspot.com/2018/03/an-unusual-22-tone-7-limit-tuning.html>++7-limit 22-tone scale {SCALA=nil}++> ew_scl_find_r ew_two_22_7_r+-}+ew_two_22_7_r :: [Rational]+ew_two_22_7_r =+  [1/1,9/35,1/15,35/1,9/1,7/3,3/5,315/1,245/3,21/1,27/5+  ,7/5,735/1,189/1,49/1,63/5,5/3,3/7,1/9,1/35,15/1,35/9]++ew_two_22_7_scl :: T.Scale+ew_two_22_7_scl = r_to_scale "ew_two_22_7" "EW, 2018/03/an-unusual-22-tone-7-limit-tuning.html" ew_two_22_7_r++-- * DB++{- | Scales /not/ present in the standard scala file set.++> mapM_ (T.scale_wr_dir "/home/rohan/sw/hmt/data/scl/") ew_scl_db+> map T.scale_name ew_scl_db+-}+ew_scl_db :: [T.Scale]+ew_scl_db =+  [ew_1357_3_scl+  ,ew_el12_7_scl+  ,ew_el12_12_scl+  ,ew_hel_12_scl+  ,ew_novarotreediamond_1_scl+  ,ew_Pelogflute_2_scl+  ,ew_xen3b_3_scl+  ,ew_xen456_9_scl+  ,ew_poole_scl+  ,ew_two_22_7_scl+  ]++-- Local Variables:+-- truncate-lines:t+-- End:
Music/Theory/Tuple.hs view
@@ -46,6 +46,10 @@ t2_sort :: Ord t => (t,t) -> (t,t) t2_sort (p,q) = (min p q,max p q) +-- | T2 variant of 'sum'+t2_sum :: Num n => (n,n) -> n+t2_sum (i,j) = i + j+ -- * P3 (3-product)  -- | Left rotation.@@ -111,6 +115,9 @@ p4_fourth :: (a,b,c,d) -> d p4_fourth (_,_,_,d) = d +p4_zip :: (a,b,c,d) -> (e,f,g,h) -> ((a,e),(b,f),(c,g),(d,h))+p4_zip (a,b,c,d) (e,f,g,h) = ((a,e),(b,f),(c,g),(d,h))+ -- * T4 (4-tuple, regular)  type T4 a = (a,a,a,a)@@ -317,3 +324,46 @@ t12_sum t =     let (n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12) = t     in n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8 + n9 + n10 + n11 + n12++-- * Family of 'uncurry' functions.++uncurry3 :: (a->b->c -> z) -> (a,b,c) -> z+uncurry3 fn (a,b,c) = fn a b c+uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d) -> z+uncurry4 fn (a,b,c,d) = fn a b c d+uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e) -> z+uncurry5 fn (a,b,c,d,e) = fn a b c d e+uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f) -> z+uncurry6 fn (a,b,c,d,e,f) = fn a b c d e f+uncurry7 :: (a->b->c->d->e->f->g -> z) -> (a,b,c,d,e,f,g) -> z+uncurry7 fn (a,b,c,d,e,f,g) = fn a b c d e f g+uncurry8 :: (a->b->c->d->e->f->g->h -> z) -> (a,b,c,d,e,f,g,h) -> z+uncurry8 fn (a,b,c,d,e,f,g,h) = fn a b c d e f g h+uncurry9 :: (a->b->c->d->e->f->g->h->i -> z) -> (a,b,c,d,e,f,g,h,i) -> z+uncurry9 fn (a,b,c,d,e,f,g,h,i) = fn a b c d e f g h i+uncurry10 :: (a->b->c->d->e->f->g->h->i->j -> z) -> (a,b,c,d,e,f,g,h,i,j) -> z+uncurry10 fn (a,b,c,d,e,f,g,h,i,j) = fn a b c d e f g h i j+uncurry11 :: (a->b->c->d->e->f->g->h->i->j->k -> z) -> (a,b,c,d,e,f,g,h,i,j,k) -> z+uncurry11 fn (a,b,c,d,e,f,g,h,i,j,k) = fn a b c d e f g h i j k+uncurry12 :: (a->b->c->d->e->f->g->h->i->j->k->l -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l) -> z+uncurry12 fn (a,b,c,d,e,f,g,h,i,j,k,l) = fn a b c d e f g h i j k l+uncurry13 :: (a->b->c->d->e->f->g->h->i->j->k->l->m -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) -> z+uncurry13 fn (a,b,c,d,e,f,g,h,i,j,k,l,m) = fn a b c d e f g h i j k l m+uncurry14 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> z+uncurry14 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = fn a b c d e f g h i j k l m n+uncurry15 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -> z+uncurry15 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = fn a b c d e f g h i j k l m n o+uncurry16 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> z+uncurry16 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = fn a b c d e f g h i j k l m n o p+uncurry17 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) -> z+uncurry17 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = fn a b c d e f g h i j k l m n o p q+uncurry18 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) -> z+uncurry18 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = fn a b c d e f g h i j k l m n o p q r+uncurry19 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) -> z+uncurry19 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = fn a b c d e f g h i j k l m n o p q r s+uncurry20 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) -> z+uncurry20 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = fn a b c d e f g h i j k l m n o p q r s t++-- Local Variables:+-- truncate-lines:t+-- End:
Music/Theory/Unicode.hs view
@@ -4,6 +4,7 @@ -- debian=ttf-freefont. module Music.Theory.Unicode where +import Data.Char {- base -} import Data.List {- base -} import Numeric {- base -} @@ -27,26 +28,114 @@ non_breaking_space :: Char non_breaking_space = toEnum 0x00A0 --- * Music+-- | Unicode interpunct.+--+-- > middle_dot == '·'+middle_dot :: Char+middle_dot = toEnum 0x00B7 +-- | The superscript variants of the digits 0-9+superscript_digits :: [Char]+superscript_digits = "⁰¹²³⁴⁵⁶⁷⁸⁹"++-- | Map 'show' of 'Int' to 'superscript_digits'.+--+-- > unwords (map int_show_superscript [0,12,345,6789]) == "⁰ ¹² ³⁴⁵ ⁶⁷⁸⁹"+int_show_superscript :: Int -> String+int_show_superscript = map ((superscript_digits !!) . digitToInt) . show++-- | The subscript variants of the digits 0-9+subscript_digits :: [Char]+subscript_digits = "₀₁₂₃₄₅₆₇₈₉"++-- | The combining over line character.+--+-- > ['1',combining_overline] == "1̅"+combining_overline :: Char+combining_overline = toEnum 0x0305++-- | Add 'combining_overline' to each 'Char'.+--+-- > overline "1234" == "1̅2̅3̅4̅"+overline :: String -> String+overline = let f x = [x,combining_overline] in concatMap f++-- | The combining under line character.+--+-- > ['1',combining_underline] == "1̲"+combining_underline :: Char+combining_underline = toEnum 0x0332++-- | Add 'combining_underline' to each 'Char'.+--+-- > underline "1234" == "1̲2̲3̲4̲"+underline :: String -> String+underline = let f x = [x,combining_underline] in concatMap f++-- * Table+ type Unicode_Index = Int+type Unicode_Name = String type Unicode_Range = (Unicode_Index,Unicode_Index)-type Unicode_Point = (Unicode_Index,String)+type Unicode_Point = (Unicode_Index,Unicode_Name) type Unicode_Table = [Unicode_Point] --- > putStrLn$ map (toEnum . fst) (concat unicode)-unicode :: [Unicode_Table]-unicode = [accidentals,notes,rests,clefs]+{- | <http://unicode.org/Public/11.0.0/ucd/UnicodeData.txt> +> let fn = "/home/rohan/data/unicode.org/Public/11.0.0/ucd/UnicodeData.txt"+> tbl <- unicode_data_table_read fn+> length tbl == 32292+> T.reverse_lookup_err "MIDDLE DOT" tbl == 0x00B7+> putStrLn $ unwords $ map (\(n,x) -> toEnum n : x) $ filter (\(_,x) -> "EMPTY SET" `isInfixOf` x) tbl+> T.lookup_err 0x22C5 tbl == "DOT OPERATOR"+-}+unicode_data_table_read :: FilePath -> IO Unicode_Table+unicode_data_table_read fn = do+  s <- T.read_file_utf8 fn+  let t = C.fromCSVTable (C.csvTable (C.parseDSV False ';' s))+      f x = (T.read_hex_err (x !! 0),x !! 1)+  return (map f t)++unicode_table_block :: (Unicode_Index,Unicode_Index) -> Unicode_Table -> Unicode_Table+unicode_table_block (l,r) = takeWhile ((<= r) . fst) . dropWhile ((< l) . fst)++unicode_point_hs :: Unicode_Point -> String+unicode_point_hs (n,s) = concat ["(0x",showHex n "",",\"",s,"\")"]++unicode_table_hs :: Unicode_Table -> String+unicode_table_hs = T.bracket ('[',']') . intercalate "," . map unicode_point_hs++-- * Music++-- > putStrLn$ map (toEnum . fst) (concat music_tbl)+music_tbl :: [Unicode_Table]+music_tbl = [barlines_tbl,accidentals_tbl,notes_tbl,rests_tbl,clefs_tbl]+ -- > putStrLn$ concatMap (unicode_table_hs . flip unicode_table_block tbl) accidentals_rng_set accidentals_rng_set :: [Unicode_Range] accidentals_rng_set = [(0x266D,0x266F),(0x1D12A,0x1D133)] +-- > putStrLn$ unicode_table_hs (unicode_table_block barlines_rng tbl)+barlines_rng :: Unicode_Range+barlines_rng = (0x1D100,0x1D105)++-- | UNICODE barline symbols.+--+-- > let r = "𝄀𝄁𝄂𝄃𝄄𝄅" in map (toEnum . fst) barlines_tbl == r+barlines_tbl :: Unicode_Table+barlines_tbl =+  [(0x1D100,"MUSICAL SYMBOL SINGLE BARLINE")+  ,(0x1D101,"MUSICAL SYMBOL DOUBLE BARLINE")+  ,(0x1D102,"MUSICAL SYMBOL FINAL BARLINE")+  ,(0x1D103,"MUSICAL SYMBOL REVERSE FINAL BARLINE")+  ,(0x1D104,"MUSICAL SYMBOL DASHED BARLINE")+  ,(0x1D105,"MUSICAL SYMBOL SHORT BARLINE")]+ -- | UNICODE accidental symbols. ----- > let r = "♭♮♯𝄪𝄫𝄬𝄭𝄮𝄯𝄰𝄱𝄲𝄳" in map (toEnum . fst) accidentals == r-accidentals :: Unicode_Table-accidentals =+-- > let r = "♭♮♯𝄪𝄫𝄬𝄭𝄮𝄯𝄰𝄱𝄲𝄳" in map (toEnum . fst) accidentals_tbl == r+accidentals_tbl :: Unicode_Table+accidentals_tbl =     [(0x266D,"MUSIC FLAT SIGN")     ,(0x266E,"MUSIC NATURAL SIGN")     ,(0x266F,"MUSIC SHARP SIGN")@@ -67,9 +156,9 @@  -- | UNICODE note duration symbols. ----- > let r = "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲" in map (toEnum . fst) notes == r-notes :: Unicode_Table-notes =+-- > let r = "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲" in map (toEnum . fst) notes_tbl == r+notes_tbl :: Unicode_Table+notes_tbl =     [(0x1D15C,"MUSICAL SYMBOL BREVE")     ,(0x1D15D,"MUSICAL SYMBOL WHOLE NOTE")     ,(0x1D15E,"MUSICAL SYMBOL HALF NOTE")@@ -86,9 +175,9 @@  -- | UNICODE rest symbols. ----- > let r = "𝄻𝄼𝄽𝄾𝄿𝅀𝅁𝅂" in map (toEnum . fst) rests == r-rests :: Unicode_Table-rests =+-- > let r = "𝄻𝄼𝄽𝄾𝄿𝅀𝅁𝅂" in map (toEnum . fst) rests_tbl == r+rests_tbl :: Unicode_Table+rests_tbl =     [(0x1D13B,"MUSICAL SYMBOL WHOLE REST")     ,(0x1D13C,"MUSICAL SYMBOL HALF REST")     ,(0x1D13D,"MUSICAL SYMBOL QUARTER REST")@@ -98,6 +187,8 @@     ,(0x1D141,"MUSICAL SYMBOL SIXTY-FOURTH REST")     ,(0x1D142,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH REST")] +-- | Augmentation dot.+-- -- > map toEnum [0x1D15E,0x1D16D,0x1D16D] == "𝅗𝅥𝅭𝅭" augmentation_dot :: Unicode_Point augmentation_dot = (0x1D16D, "MUSICAL SYMBOL COMBINING AUGMENTATION DOT")@@ -108,9 +199,9 @@  -- | UNICODE clef symbols. ----- > let r = "𝄞𝄟𝄠𝄡𝄢𝄣𝄤𝄥𝄦" in map (toEnum . fst) clefs == r-clefs :: Unicode_Table-clefs =+-- > let r = "𝄞𝄟𝄠𝄡𝄢𝄣𝄤𝄥𝄦" in map (toEnum . fst) clefs_tbl == r+clefs_tbl :: Unicode_Table+clefs_tbl =     [(0x1D11E,"MUSICAL SYMBOL G CLEF")     ,(0x1D11F,"MUSICAL SYMBOL G CLEF OTTAVA ALTA")     ,(0x1D120,"MUSICAL SYMBOL G CLEF OTTAVA BASSA")@@ -121,15 +212,15 @@     ,(0x1D125,"MUSICAL SYMBOL DRUM CLEF-1")     ,(0x1D126,"MUSICAL SYMBOL DRUM CLEF-2")] --- > putStrLn$ unicode_table_hs (unicode_table_block tbl notehead_rng)-notehead_rng :: Unicode_Range-notehead_rng = (0x1D143,0x1D15B)+-- > putStrLn$ unicode_table_hs (unicode_table_block noteheads_rng tbl)+noteheads_rng :: Unicode_Range+noteheads_rng = (0x1D143,0x1D15B)  -- | UNICODE notehead symbols. ----- > let r = "𝅃𝅄𝅅𝅆𝅇𝅈𝅉𝅊𝅋𝅌𝅍𝅎𝅏𝅐𝅑𝅒𝅓𝅔𝅕𝅖𝅗𝅘𝅙𝅚𝅛" in map (toEnum . fst) noteheads == r-noteheads :: Unicode_Table-noteheads =+-- > let r = "𝅃𝅄𝅅𝅆𝅇𝅈𝅉𝅊𝅋𝅌𝅍𝅎𝅏𝅐𝅑𝅒𝅓𝅔𝅕𝅖𝅗𝅘𝅙𝅚𝅛" in map (toEnum . fst) noteheads_tbl == r+noteheads_tbl :: Unicode_Table+noteheads_tbl =     [(0x1d143,"MUSICAL SYMBOL X NOTEHEAD")     ,(0x1d144,"MUSICAL SYMBOL PLUS NOTEHEAD")     ,(0x1d145,"MUSICAL SYMBOL CIRCLE X NOTEHEAD")@@ -164,9 +255,9 @@ dynamics_rng :: Unicode_Range dynamics_rng = (0x1D18C,0x1D193) --- > map (toEnum . fst) dynamics == "𝆌𝆍𝆎𝆏𝆐𝆑𝆒𝆓"-dynamics :: Unicode_Table-dynamics =+-- > map (toEnum . fst) dynamics_tbl == "𝆌𝆍𝆎𝆏𝆐𝆑𝆒𝆓"+dynamics_tbl :: Unicode_Table+dynamics_tbl =     [(0x1d18c,"MUSICAL SYMBOL RINFORZANDO")     ,(0x1d18d,"MUSICAL SYMBOL SUBITO")     ,(0x1d18e,"MUSICAL SYMBOL Z")@@ -180,9 +271,9 @@ articulations_rng :: Unicode_Range articulations_rng = (0x1D17B,0x1D18B) --- > putStrLn (map (toEnum . fst) articulations :: String)-articulations :: Unicode_Table-articulations =+-- > putStrLn (map (toEnum . fst) articulations_tbl :: String)+articulations_tbl :: Unicode_Table+articulations_tbl =     [(0x1d17b,"MUSICAL SYMBOL COMBINING ACCENT")     ,(0x1d17c,"MUSICAL SYMBOL COMBINING STACCATO")     ,(0x1d17d,"MUSICAL SYMBOL COMBINING TENUTO")@@ -201,6 +292,27 @@     ,(0x1d18a,"MUSICAL SYMBOL COMBINING DOUBLE TONGUE")     ,(0x1d18b,"MUSICAL SYMBOL COMBINING TRIPLE TONGUE")] +-- * Math++ix_set_to_tbl :: Unicode_Table -> [Unicode_Index] -> Unicode_Table+ix_set_to_tbl tbl ix = zip ix (map (flip T.lookup_err tbl) ix)++-- | Unicode dot-operator.+--+-- > dot_operator == '⋅'+dot_operator :: Char+dot_operator = toEnum 0x22C5++-- | Math symbols outside of the math blocks.+--+-- > putStrLn (unicode_table_hs (ix_set_to_tbl tbl math_plain_ix))+math_plain_ix :: [Unicode_Index]+math_plain_ix = [0x00D7,0x00F7]++-- > map (toEnum . fst) math_plain_tbl == "×÷"+math_plain_tbl :: Unicode_Table+math_plain_tbl = [(0xd7,"MULTIPLICATION SIGN"),(0xf7,"DIVISION SIGN")]+ -- * Blocks  type Unicode_Block = (Unicode_Range,String)@@ -208,32 +320,189 @@ -- > putStrLn$ unicode_table_hs (concatMap (flip unicode_table_block tbl . fst) unicode_blocks) unicode_blocks :: [Unicode_Block] unicode_blocks =-    [((0x1B00,0x1B7F),"Balinese")-    ,((0x2200,0x22FF),"Mathematical Operators")-    ,((0x25A0,0x25FF),"Geometric Shapes")+    [((0x01B00,0x01B7F),"Balinese")+    ,((0x02200,0x022FF),"Mathematical Operators")+    ,((0x025A0,0x025FF),"Geometric Shapes")+    ,((0x027C0,0x027EF),"Miscellaneous Mathematical Symbols-A")+    ,((0x027F0,0x027FF),"Supplemental Arrows-A")+    ,((0x02800,0x028FF),"Braille Patterns")+    ,((0x02900,0x0297F),"Supplemental Arrows-B")+    ,((0x02980,0x029FF),"Miscellaneous Mathematical Symbols-B")+    ,((0x02A00,0x02AFF),"Supplemental Mathematical Operators")     ,((0x1D000,0x1D0FF),"Byzantine Musical Symbols")     ,((0x1D100,0x1D1FF),"Musical Symbols")-    ,((0x1D200,0x1D24F),"Ancient Greek Musical Notation")]+    ,((0x1D200,0x1D24F),"Ancient Greek Musical Notation")+    ] --- * Table+-- * BAGUA, EIGHT TRI-GRAMS --- | <http://unicode.org/Public/8.0.0/ucd/UnicodeData.txt>+-- | Bagua tri-grams. ----- > let fn = "/home/rohan/data/unicode.org/Public/8.0.0/ucd/UnicodeData.txt"--- > tbl <- unicode_data_table_read fn--- > length tbl == 29215-unicode_data_table_read :: FilePath -> IO Unicode_Table-unicode_data_table_read fn = do-  s <- T.read_file_utf8 fn-  let t = C.fromCSVTable (C.csvTable (C.parseDSV False ';' s))-      f x = (T.read_hex_err (x !! 0),x !! 1)-  return (map f t)+-- > putStrLn $ unicode_table_hs (unicode_table_block (fst bagua) tbl)+bagua :: Unicode_Block+bagua = ((0x02630,0x02637),"BAGUA") -unicode_table_block :: (Int,Int) -> Unicode_Table -> Unicode_Table-unicode_table_block (l,r) = takeWhile ((<= r) . fst) . dropWhile ((< l) . fst)+{- | Table of eight tri-grams. -unicode_point_hs :: Unicode_Point -> String-unicode_point_hs (n,s) = concat ["(0x",showHex n "",",\"",s,"\")"]+HEAVEN,乾,Qián,☰,111+LAKE,兌,Duì,☱,110+FIRE,離,Lí,☲,101+THUNDER,震,Zhèn,☳,100+WIND,巽,Xùn,☴,011+WATER,坎,Kǎn,☵,010+MOUNTAIN,艮,Gèn,☶,001+EARTH,坤,Kūn,☷,000 -unicode_table_hs :: Unicode_Table -> String-unicode_table_hs = T.bracket ('[',']') . intercalate "," . map unicode_point_hs+-}+bagua_tbl :: Unicode_Table+bagua_tbl =+  [(0x2630,"TRIGRAM FOR HEAVEN")+  ,(0x2631,"TRIGRAM FOR LAKE")+  ,(0x2632,"TRIGRAM FOR FIRE")+  ,(0x2633,"TRIGRAM FOR THUNDER")+  ,(0x2634,"TRIGRAM FOR WIND")+  ,(0x2635,"TRIGRAM FOR WATER")+  ,(0x2636,"TRIGRAM FOR MOUNTAIN")+  ,(0x2637,"TRIGRAM FOR EARTH")]++-- * YIJING (I-CHING), SIXTY-FOUR HEXAGRAMS++-- | Yijing hexagrams in King Wen sequence.+--+-- > putStrLn $ unicode_table_hs (unicode_table_block (fst yijing) tbl)+yijing :: Unicode_Block+yijing = ((0x04DC0,0x04DFF),"YIJING")++{- | Yijing hexagrams in King Wen sequence.++䷀,乾,qián,111,111+䷁,坤,kūn,000,000+䷂,屯,chún,100,010+䷃,蒙,méng,010,001+䷄,需,xū,111,010+䷅,訟,sòng,010,111+䷆,師,shī,010,000+䷇,比,bǐ,000,010+䷈,小畜,xiǎo chù,111,011+䷉,履,lǚ,110,111+䷊,泰,tài,111,000+䷋,否,pǐ,000,111+䷌,同人,tóng rén,101,111+䷍,大有,dà yǒu,111,101+䷎,謙,qiān,001,000+䷏,豫,yù,000,100+䷐,隨,suí,100,110+䷑,蠱,gŭ,011,001+䷒,臨,lín,110,000+䷓,觀,guān,000,011+䷔,噬嗑,shì kè,100,101+䷕,賁,bì,101,001+䷖,剝,bō,000,001+䷗,復,fù,100,000+䷘,無妄,wú wàng,100,111+䷙,大畜,dà chù,111,001+䷚,頤,yí,100,001+䷛,大過,dà guò,011,110+䷜,坎,kǎn,010,010+䷝,離,lí,101,101+䷞,咸,xián,001,110+䷟,恆,héng,011,100+䷠,遯,dùn,001,111+䷡,大壯,dà zhuàng,111,100+䷢,晉,jìn,000,101+䷣,明夷,míng yí,101,000+䷤,家人,jiā rén,101,011+䷥,睽,kuí,110,101+䷦,蹇,jiǎn,001,010+䷧,解,xiè,010,100+䷨,損,sǔn,110,001+䷩,益,yì,100,011+䷪,夬,guài,111,110+䷫,姤,gòu,011,111+䷬,萃,cuì,000,110+䷭,升,shēng,011,000+䷮,困,kùn,010,110+䷯,井,jǐng,011,010+䷰,革,gé,101,110+䷱,鼎,dǐng,011,101+䷲,震,zhèn,100,100+䷳,艮,gèn,001,001+䷴,漸,jiàn,001,011+䷵,歸妹,guī mèi,110,100+䷶,豐,fēng,101,100+䷷,旅,lǚ,001,101+䷸,巽,xùn,011,011+䷹,兌,duì,110,110+䷺,渙,huàn,010,011+䷻,節,jié,110,010+䷼,中孚,zhōng fú,110,011+䷽,小過,xiǎo guò,001,110+䷾,既濟,jì jì,101,010+䷿,未濟,wèi jì,010,101+-}+yijing_tbl :: Unicode_Table+yijing_tbl =+  [(0x4dc0,"HEXAGRAM FOR THE CREATIVE HEAVEN")+  ,(0x4dc1,"HEXAGRAM FOR THE RECEPTIVE EARTH")+  ,(0x4dc2,"HEXAGRAM FOR DIFFICULTY AT THE BEGINNING")+  ,(0x4dc3,"HEXAGRAM FOR YOUTHFUL FOLLY")+  ,(0x4dc4,"HEXAGRAM FOR WAITING")+  ,(0x4dc5,"HEXAGRAM FOR CONFLICT")+  ,(0x4dc6,"HEXAGRAM FOR THE ARMY")+  ,(0x4dc7,"HEXAGRAM FOR HOLDING TOGETHER")+  ,(0x4dc8,"HEXAGRAM FOR SMALL TAMING")+  ,(0x4dc9,"HEXAGRAM FOR TREADING")+  ,(0x4dca,"HEXAGRAM FOR PEACE")+  ,(0x4dcb,"HEXAGRAM FOR STANDSTILL")+  ,(0x4dcc,"HEXAGRAM FOR FELLOWSHIP")+  ,(0x4dcd,"HEXAGRAM FOR GREAT POSSESSION")+  ,(0x4dce,"HEXAGRAM FOR MODESTY")+  ,(0x4dcf,"HEXAGRAM FOR ENTHUSIASM")+  ,(0x4dd0,"HEXAGRAM FOR FOLLOWING")+  ,(0x4dd1,"HEXAGRAM FOR WORK ON THE DECAYED")+  ,(0x4dd2,"HEXAGRAM FOR APPROACH")+  ,(0x4dd3,"HEXAGRAM FOR CONTEMPLATION")+  ,(0x4dd4,"HEXAGRAM FOR BITING THROUGH")+  ,(0x4dd5,"HEXAGRAM FOR GRACE")+  ,(0x4dd6,"HEXAGRAM FOR SPLITTING APART")+  ,(0x4dd7,"HEXAGRAM FOR RETURN")+  ,(0x4dd8,"HEXAGRAM FOR INNOCENCE")+  ,(0x4dd9,"HEXAGRAM FOR GREAT TAMING")+  ,(0x4dda,"HEXAGRAM FOR MOUTH CORNERS")+  ,(0x4ddb,"HEXAGRAM FOR GREAT PREPONDERANCE")+  ,(0x4ddc,"HEXAGRAM FOR THE ABYSMAL WATER")+  ,(0x4ddd,"HEXAGRAM FOR THE CLINGING FIRE")+  ,(0x4dde,"HEXAGRAM FOR INFLUENCE")+  ,(0x4ddf,"HEXAGRAM FOR DURATION")+  ,(0x4de0,"HEXAGRAM FOR RETREAT")+  ,(0x4de1,"HEXAGRAM FOR GREAT POWER")+  ,(0x4de2,"HEXAGRAM FOR PROGRESS")+  ,(0x4de3,"HEXAGRAM FOR DARKENING OF THE LIGHT")+  ,(0x4de4,"HEXAGRAM FOR THE FAMILY")+  ,(0x4de5,"HEXAGRAM FOR OPPOSITION")+  ,(0x4de6,"HEXAGRAM FOR OBSTRUCTION")+  ,(0x4de7,"HEXAGRAM FOR DELIVERANCE")+  ,(0x4de8,"HEXAGRAM FOR DECREASE")+  ,(0x4de9,"HEXAGRAM FOR INCREASE")+  ,(0x4dea,"HEXAGRAM FOR BREAKTHROUGH")+  ,(0x4deb,"HEXAGRAM FOR COMING TO MEET")+  ,(0x4dec,"HEXAGRAM FOR GATHERING TOGETHER")+  ,(0x4ded,"HEXAGRAM FOR PUSHING UPWARD")+  ,(0x4dee,"HEXAGRAM FOR OPPRESSION")+  ,(0x4def,"HEXAGRAM FOR THE WELL")+  ,(0x4df0,"HEXAGRAM FOR REVOLUTION")+  ,(0x4df1,"HEXAGRAM FOR THE CAULDRON")+  ,(0x4df2,"HEXAGRAM FOR THE AROUSING THUNDER")+  ,(0x4df3,"HEXAGRAM FOR THE KEEPING STILL MOUNTAIN")+  ,(0x4df4,"HEXAGRAM FOR DEVELOPMENT")+  ,(0x4df5,"HEXAGRAM FOR THE MARRYING MAIDEN")+  ,(0x4df6,"HEXAGRAM FOR ABUNDANCE")+  ,(0x4df7,"HEXAGRAM FOR THE WANDERER")+  ,(0x4df8,"HEXAGRAM FOR THE GENTLE WIND")+  ,(0x4df9,"HEXAGRAM FOR THE JOYOUS LAKE")+  ,(0x4dfa,"HEXAGRAM FOR DISPERSION")+  ,(0x4dfb,"HEXAGRAM FOR LIMITATION")+  ,(0x4dfc,"HEXAGRAM FOR INNER TRUTH")+  ,(0x4dfd,"HEXAGRAM FOR SMALL PREPONDERANCE")+  ,(0x4dfe,"HEXAGRAM FOR AFTER COMPLETION")+  ,(0x4dff,"HEXAGRAM FOR BEFORE COMPLETION")]
Music/Theory/Xenakis/S4.hs view
@@ -5,8 +5,10 @@  import Data.List {- base -} import Data.Maybe {- base -}+ import qualified Data.Permute as P {- permutation -} +import qualified Music.Theory.List as T import qualified Music.Theory.Permutations as T  -- * S4 notation@@ -76,30 +78,29 @@ > import qualified Music.Theory.List as T  > let r = [D,Q12,Q4, E,Q8,Q2, E2,Q7,Q4, D2,Q3,Q11, L2,Q7,Q2, L,Q8,Q11]-> in (take 18 (fib_proc l_on D Q12) == r,T.duplicates r == [Q2,Q4,Q7,Q8,Q11])+> (take 18 (fib_proc l_on D Q12) == r,T.duplicates r == [Q2,Q4,Q7,Q8,Q11])  Beginning E then G2 no Q nodes are visited.  > let r = [E,G2,L2,C,G,D,E,B,D2,L,G,C,L2,E2,D2,B]-> in (take 16 (fib_proc l_on E G2) == r,T.duplicates r == [B,C,D2,E,G,L2])+> (take 16 (fib_proc l_on E G2) == r,T.duplicates r == [B,C,D2,E,G,L2]) -> import Music.Theory.List-> let [a,b] = take 2 (segments 18 18 (fib_proc l_on D Q12)) in a == b+> let [a,b] = take 2 (T.segments 18 18 (fib_proc l_on D Q12)) in a == b  The prime numbers that are not factors of 18 are {1,5,7,11,13,17}. They form a closed group under modulo 18 multiplication. -> let {n = [5,7,11,13,17]->     ;r = [(5,7,17),(5,11,1),(5,13,11),(5,17,13)->          ,(7,11,5),(7,13,1),(7,17,11)->          ,(11,13,17),(11,17,7)->          ,(13,17,5)]}-> in [(p,q,(p * q) `mod` 18) | p <- n, q <- n, p < q] == r+> let n = [5,7,11,13,17]+> let r0 = [(5,7,17),(5,11,1),(5,13,11),(5,17,13)]+> let r1 = [(7,11,5),(7,13,1),(7,17,11)]+> let r2 = [(11,13,17),(11,17,7)]+> let r3 = [(13,17,5)]+> [(p,q,(p * q) `mod` 18) | p <- n, q <- n, p < q] == concat [r0,r1,r2,r3]  The article also omits the 5 after 5,1 in the sequence below.  > let r = [11,13,17,5,13,11,17,7,11,5,1,5,5,7,17,11,7,5,17,13,5,11,1,11]-> in take 24 (fib_proc (\p q -> (p * q) `mod` 18) 11 13) == r+> take 24 (fib_proc (\p q -> (p * q) `mod` 18) 11 13) == r  -} fib_proc :: (a -> a -> a) -> a -> a -> [a]@@ -123,15 +124,6 @@ half_seq :: Seq -> Half_Seq half_seq = take 4 --- | Reverse table 'lookup'.------ > reverse_lookup 'b' (zip [1..] ['a'..]) == Just 2--- > lookup 2 (zip [1..] ['a'..]) == Just 'b'-reverse_lookup :: (Eq a) => a -> [(b,a)] -> Maybe b-reverse_lookup i =-    let f (p,q) = (q,p)-    in lookup i . map f- -- | 'Label' of 'Seq', inverse of 'seq_of'. -- -- > label_of [8,7,5,6,4,3,1,2] == Q1@@ -139,7 +131,7 @@ label_of :: Seq -> Label label_of i =     let err = error ("label_of: " ++ show i)-    in fromMaybe err (reverse_lookup i viii_6b)+    in fromMaybe err (T.reverse_lookup i viii_6b)  -- | 'True' if two 'Half_Seq's are complementary, ie. form a 'Seq'. --@@ -212,11 +204,10 @@ data Face = F_Back | F_Front | F_Right | F_Left | F_Bottom | F_Top           deriving (Eq,Enum,Bounded,Ord,Show) --- | Table indicating set of faces of cubes as drawn in Fig. VIII-6--- (p.220).+-- | Table indicating set of faces of cubes as drawn in Fig. VIII-6 (p.220). -- -- > lookup [1,4,6,7] faces == Just F_Left--- > reverse_lookup F_Right faces == Just [2,3,5,8]+-- > T.reverse_lookup F_Right faces == Just [2,3,5,8] faces :: [([Int],Face)] faces =     [([1,3,6,8],F_Back) -- (I in viii-6)
Music/Theory/Z.hs view
@@ -1,4 +1,4 @@--- | Z-/n/ functions with modulo function as parameter.+-- | Z-/n/ functions module Music.Theory.Z where  import Data.Char {- base -}@@ -6,65 +6,69 @@  import qualified Music.Theory.List as T {- hmt -} --- | The modulo function for Z.-type Z t = (t -> t)+-- | Z type.+--+-- > map z_modulus [z7,z12] == [7,12]+data Z i = Z {z_modulus :: i} +-- | 'mod' of 'Z'.+--+-- > map (z_mod z12) [-1,0,1,11,12,13] == [11,0,1,11,0,1]+z_mod :: Integral i => Z i -> i -> i+z_mod (Z i) n = mod n i++-- | Common moduli in music theory.+z5,z7,z12,z16 :: Num i => Z i+z5 = Z 5+z7 = Z 7+z12 = Z 12+z16 = Z 16+ -- | Is /n/ in (0,/m/-1). is_z_n :: (Num a, Ord a) => a -> a -> Bool is_z_n m n = n >= 0 && n < m -mod5 :: Integral i => Z i-mod5 n = n `mod` 5--mod7 :: Integral i => Z i-mod7 n = n `mod` 7--mod12 :: Integral i => Z i-mod12 n = n `mod` 12--lift_unary_Z :: Z i -> (t -> i) -> t -> i-lift_unary_Z z f n = z (f n)+lift_unary_Z :: Integral i => Z i -> (t -> i) -> t -> i+lift_unary_Z z f = z_mod z . f -lift_binary_Z :: Z i -> (s -> t -> i) -> s -> t -> i-lift_binary_Z z f n1 n2 = z (n1 `f` n2)+lift_binary_Z :: Integral i => Z i -> (s -> t -> i) -> s -> t -> i+lift_binary_Z z f n1 = z_mod z . f n1 --- > import Music.Theory.Z--- > import qualified Music.Theory.Z12 as Z12--- > z_add id (11::Z12.Z12) 5 == 4--- > (11::Z12.Z12) + 5 == 4--- > map (z_add mod12 4) [1,5,6] == [5,9,10]+-- | Add two Z.+--+-- > map (z_add z12 4) [1,5,6,11] == [5,9,10,3] z_add :: Integral i => Z i -> i -> i -> i z_add z = lift_binary_Z z (+)  -- | The underlying type /i/ is presumed to be signed... ----- > z_sub mod12 0 8 == 4+-- > z_sub z12 0 8 == 4 ----- > import Data.Word--- > z_sub mod12 (0::Word8) 8 == 8+-- > import Data.Word {- base -}+-- > z_sub z12 (0::Word8) 8 == 8 -- > ((0 - 8) :: Word8) == 248 -- > 248 `mod` 12 == 8 z_sub :: Integral i => Z i -> i -> i -> i z_sub z = lift_binary_Z z (-) -{- | Allowing unsigned /i/ is rather inefficient...-z_sub :: Integral i => Z i -> i -> i -> i-z_sub z p q =+-- | Allowing unsigned /i/ is rather inefficient...+--+-- > z_sub_unsigned z12 (0::Word8) 8 == 4+z_sub_unsigned :: (Integral i,Ord i) => Z i -> i -> i -> i+z_sub_unsigned z p q =     if p > q-    then z (p - q)-    else let m = z_modulus z-         in z (p + m - q)--}+    then z_mod z (p - q)+    else z_mod z (p + z_modulus z - q)  z_mul :: Integral i => Z i -> i -> i -> i z_mul z = lift_binary_Z z (*) --- > z_negate mod12 7 == 5+-- > z_negate z12 7 == 5 z_negate :: Integral i => Z i -> i -> i z_negate z = z_sub z 0 -- error "Z numbers are not signed"  z_fromInteger :: Integral i => Z i -> Integer -> i-z_fromInteger z i = z (fromInteger i)+z_fromInteger z i = z_mod z (fromInteger i)  z_signum :: t -> u -> v z_signum _ _ = error "Z numbers are not signed"@@ -72,29 +76,23 @@ z_abs :: t -> u -> v z_abs _ _ = error "Z numbers are not signed" --- > map (to_Z mod12) [-9,-3,0] == [3,9,0]+-- > map (to_Z z12) [-9,-3,0] == [3,9,0] to_Z :: Integral i => Z i -> i -> i to_Z z = z_fromInteger z . fromIntegral  from_Z :: (Integral i,Num n) => i -> n-from_Z = fromIntegral---- | Modulus of /z/.------ > z_modulus mod12 == 12-z_modulus :: Integral i => Z i -> i-z_modulus z = maybe (error "z_modulus") (fromIntegral . (+ 1)) (findIndex ((== 0) . z) [1..])+from_Z i = fromIntegral i  -- | Universe of 'Z'. ----- > z_univ mod12 == [0..11]+-- > z_univ z12 == [0..11] z_univ :: Integral i => Z i -> [i]-z_univ z = 0 : takeWhile ((> 0) . z) [1..]+z_univ (Z z) = [0 .. z - 1]  -- | Z of 'z_univ' not in given set. ----- > z_complement mod5 [0,2,3] == [1,4]--- > z_complement mod12 [0,2,4,5,7,9,11] == [1,3,6,8,10]+-- > z_complement z5 [0,2,3] == [1,4]+-- > z_complement z12 [0,2,4,5,7,9,11] == [1,3,6,8,10] z_complement :: Integral i => Z i -> [i] -> [i] z_complement z = (\\) (z_univ z) @@ -110,38 +108,39 @@ z_div :: Integral i => Z i -> i -> i -> i z_div z p = to_Z z . div_err "z_div" p --- > z_mod mod12 6 12 == 6-z_mod :: Integral i => Z i -> i -> i -> i-z_mod z p = to_Z z . mod p- z_quotRem :: Integral i => Z i -> i -> i -> (i,i) z_quotRem z p q = (z_quot z p q,z_quot z p q)  z_divMod :: Integral i => Z i -> i -> i -> (i,i)-z_divMod z p q = (z_div z p q,z_mod z p q)+z_divMod z p q = (z_div z p q,z_mod z (mod p q))  z_toInteger :: Integral i => Z i -> i -> i z_toInteger z = to_Z z  -- * Z16 -mod16 :: Integral i => Z i-mod16 n = n `mod` 16-+-- | Type generalised 'intToDigit'.+--+-- > map integral_to_digit [0 .. 15] == "0123456789abcdef" integral_to_digit :: Integral t => t -> Char integral_to_digit = intToDigit . fromIntegral +-- | 'is_z_n' 16. is_z16 :: Integral t => t -> Bool is_z16 = is_z_n 16 +-- | Alias for 'integral_to_digit'. z16_to_char :: Integral t => t -> Char z16_to_char = integral_to_digit +-- | 'z16_to_char' in braces, {1,2,3}. z16_set_pp :: Integral t => [t] -> String z16_set_pp = T.bracket ('{','}') . map z16_to_char +-- | 'z16_to_char' in arrows, <1,2,3>. z16_seq_pp :: Integral t => [t] -> String z16_seq_pp = T.bracket ('<','>') . map z16_to_char +-- | 'z16_to_char' in brackets, [1,2,3]. z16_vec_pp :: Integral t => [t] -> String z16_vec_pp = T.bracket ('[',']') . map z16_to_char
Music/Theory/Z/Boros_1990.hs view
@@ -12,7 +12,7 @@ import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -} import qualified Data.Graph.Inductive.Query.BFS as G {- fgl -} -import qualified Music.Theory.Array.MD as T+import qualified Music.Theory.Array.Text as T import qualified Music.Theory.Combinations as T import qualified Music.Theory.Graph.Dot as T import qualified Music.Theory.Graph.FGL as T@@ -40,13 +40,13 @@ -- * TTO  tto_tni_univ :: Integral i => [T.TTO i]-tto_tni_univ = filter (not . T.tto_M) (T.z_tto_univ T.mod12)+tto_tni_univ = filter ((== 1) . T.tto_M) (T.z_tto_univ 5 T.z12)  all_tn :: Integral i => [i] -> [[i]]-all_tn p = map (\n -> map (T.z_add T.mod12 n) p) [0..11]+all_tn p = map (\n -> map (T.z_add T.z12 n) p) [0..11]  all_tni :: Integral i => [i] -> [[i]]-all_tni p = map (\f -> T.z_tto_apply 5 T.mod12 f p) tto_tni_univ+all_tni p = map (\f -> T.z_tto_apply T.z12 f p) tto_tni_univ  uniq_tni :: Integral i => [i] -> [[i]] uniq_tni = nub . all_tni@@ -55,20 +55,21 @@ type PCSET = [PC] type SC = PCSET +-- > pcset_trs 3 [0,1,9] == [0,3,4] pcset_trs :: Int -> PCSET -> PCSET-pcset_trs n p = sort (map (T.mod12 . (+ n)) p)+pcset_trs = T.z_tto_tn T.z12  -- | Forte prime forms of the twelve trichordal set classes. -- -- > length trichords == 12 trichords :: [PCSET]-trichords = filter ((== 3) . length) (T.sc_univ T.mod12)+trichords = filter ((== 3) . length) (T.z_sc_univ T.z12)  -- | Is a pcset self-inversional, ie. is the inversion of /p/ a transposition of /p/. -- -- > map (\p -> (p,self_inv p)) trichords self_inv :: PCSET -> Bool-self_inv p = elem_by set_eq (map (T.z_negate T.mod12) p) (all_tn p)+self_inv p = elem_by set_eq (map (T.z_negate T.z12) p) (all_tn p)  -- | Pretty printer, comma separated. --@@ -86,14 +87,14 @@  -- | Forte prime form of the all-trichord hexachord. ----- > T.sc_name T.mod12 ath == "6-Z17"+-- > T.sc_name ath == "6-Z17" -- > T.sc "6-Z17" == ath ath :: PCSET ath = [0,1,2,4,7,8]  -- | Is /p/ an instance of 'ath'. is_ath :: PCSET -> Bool-is_ath p = T.forte_prime T.mod12 p == ath+is_ath p = T.z_forte_prime T.z12 p == ath  -- | Table 1, p.20 --@@ -103,9 +104,9 @@  -- | Calculate 'T.TTO' of pcset, which must be an instance of 'ath'. ----- > ath_tni [1,2,3,7,8,11] == T.TTO 3 False True+-- > ath_tni [1,2,3,7,8,11] == T.TTO 3 1 True ath_tni :: PCSET -> T.TTO PC-ath_tni = singular "ath_tni" . filter (not . T.tto_M) . T.z_tto_rel 5 T.mod12 ath+ath_tni = singular "ath_tni" . filter ((== 1) . T.tto_M) . T.z_tto_rel 5 T.z12 ath  -- | Give label for instance of 'ath', prime forms are written H and inversions h. --@@ -144,13 +145,13 @@       _ -> [sq]  -- return edges that connect z to nodes at gr in an ATH relation-ath_gr_extend :: T.GRAPH PCSET -> PCSET -> [T.EDGE PCSET]+ath_gr_extend :: [T.EDGE PCSET] -> PCSET -> [T.EDGE PCSET] ath_gr_extend gr c =     let f x y = if is_ath (x ++ y) then Just (x,y) else Nothing         g (p,q) = mapMaybe (f c) [p,q]     in nub (map T.t2_sort (concatMap g gr)) -gr_trs :: Int -> T.GRAPH PCSET -> T.GRAPH PCSET+gr_trs :: Int -> [T.EDGE PCSET] -> [T.EDGE PCSET] gr_trs n = let f (p,q) = (pcset_trs n p,pcset_trs n q) in map f  -- * TABLES@@ -159,17 +160,20 @@ table_3 :: [((PCSET,SC,T.SC_Name),(PCSET,SC,T.SC_Name))] table_3 =     let f p = let q = ath_complement p-                  i x = (x,T.forte_prime T.mod12 x,T.sc_name T.mod12 x)+                  i x = (x,T.z_forte_prime T.z12 x,T.sc_name x)               in (i p,i q)     in map f ath_trichords +pp_tbl :: T.TABLE -> [String]+pp_tbl = T.table_pp T.table_opt_simple+ -- > putStrLn $ unlines $ table_3_md table_3_md :: [String] table_3_md =     let pp = pcset_pp_hex         f ((p,q,r),(s,t,u)) = [pp p,pp q,r,pp s,pp t,u]         hdr = ["P","P/SC","P/F","Q=H0-P","Q/SC","Q/F"]-    in T.md_table' (Just hdr,map f table_3)+    in pp_tbl (hdr : map f table_3)  -- > length table_4 == 10 table_4 :: [((PCSET,PCSET,T.SC_Name),(PCSET,PCSET,T.SC_Name))]@@ -181,16 +185,16 @@     let pp = pcset_pp_hex         f ((p,q,r),(s,t,u)) = [pp p ++ "/" ++ pp s,pp q ++ "/" ++ pp t,r ++ "/" ++ u]         hdr = ["Trichords","Prime Forms","Forte Numbers"]-    in T.md_table' (Just hdr,map f table_4)+    in pp_tbl (hdr : map f table_4)  table_5 :: [(PCSET,Int)]-table_5 = T.histogram (map (T.forte_prime T.mod12) ath_trichords)+table_5 = T.histogram (map (T.z_forte_prime T.z12) ath_trichords)  -- > putStrLn $ unlines $ table_5_md table_5_md :: [String] table_5_md =     let f (p,q) = [pcset_pp_hex p,show q]-    in T.md_table' (Just ["SC","#ATH"],map f table_5)+    in pp_tbl (["SC","#ATH"] : map f table_5)  table_6 :: [(PCSET,Int,Int)] table_6 =@@ -201,11 +205,11 @@ table_6_md :: [String] table_6_md =     let f (p,q,r) = [pcset_pp_hex p,show q,show r]-    in T.md_table' (Just ["SC","#H0","#Hn"],map f table_6)+    in pp_tbl (["SC","#H0","#Hn"] : map f table_6)  -- * FIGURES -fig_1 :: T.GRAPH PCSET+fig_1 :: [T.EDGE PCSET] fig_1 = map (T.t2_map T.p3_snd) table_4  fig_1_gr :: G.Gr PCSET ()@@ -222,19 +226,19 @@      p' = (filter (not . null) p)  in map (mapMaybe (\x -> lookup x n)) p' -fig_3 :: [T.GRAPH PCSET]+fig_3 :: [[T.EDGE PCSET]] fig_3 = map (concatMap (T.adj2 1) . realise_ath_seq) fig_2  fig_3_gr :: [G.Gr PCSET ()] fig_3_gr = map T.g_from_edges fig_3 -fig_4 :: [T.GRAPH PCSET]+fig_4 :: [[T.EDGE PCSET]] fig_4 =     let p = concatMap realise_ath_seq fig_2         q = filter ([0,1,2] `elem`) p     in map (T.adj2 1) q -fig_5 :: [T.GRAPH PCSET]+fig_5 :: [[T.EDGE PCSET]] fig_5 =     let c = [0,4,8]         f gr = case ath_gr_extend gr c of@@ -249,40 +253,40 @@ uedge_set = nub . map T.t2_sort  -- | Self-inversional pcsets are drawn in a double circle, other pcsets in a circle.-set_shape :: PCSET -> String-set_shape v = if self_inv v then "doublecircle" else "circle"+set_shape :: PCSET -> T.DOT_ATTR+set_shape v = ("shape",if self_inv v then "doublecircle" else "circle")  type GR = G.Gr PCSET ()  gr_pp' :: (PCSET -> String) -> T.GR_PP PCSET ()-gr_pp' f = (Just . set_shape,Just . f,const Nothing)+gr_pp' f = (\(_,v) -> [set_shape v,("label",f v)],const [])  gr_pp :: T.GR_PP PCSET () gr_pp = gr_pp' pcset_pp  d_fig_1 :: [String]-d_fig_1 = T.g_to_udot [] gr_pp fig_1_gr+d_fig_1 = T.fgl_to_udot [] gr_pp fig_1_gr  d_fig_3_g :: GR d_fig_3_g = T.g_from_edges (uedge_set (concat fig_3))  d_fig_3 :: [String]-d_fig_3 = T.g_to_udot [] gr_pp d_fig_3_g+d_fig_3 = T.fgl_to_udot [] gr_pp d_fig_3_g  d_fig_3' :: [[String]]-d_fig_3' = map (T.g_to_udot [("node:shape","circle")] gr_pp) fig_3_gr+d_fig_3' = map (T.fgl_to_udot [("node:shape","circle")] gr_pp) fig_3_gr  d_fig_4_g :: GR d_fig_4_g = T.g_from_edges (uedge_set (concat fig_4))  d_fig_4 :: [String]-d_fig_4 = T.g_to_udot [] gr_pp d_fig_4_g+d_fig_4 = T.fgl_to_udot [] gr_pp d_fig_4_g  d_fig_5_g :: GR d_fig_5_g = T.g_from_edges (uedge_set (concat fig_5))  d_fig_5 :: [String]-d_fig_5 = T.g_to_udot [("edge:len","1.5")] (gr_pp' pcset_pp_hex) d_fig_5_g+d_fig_5 = T.fgl_to_udot [("edge:len","1.5")] (gr_pp' pcset_pp_hex) d_fig_5_g  d_fig_5_e :: [T.EDGE_L PCSET PCSET] d_fig_5_e = map (\(p,q) -> ((p,q),p++q)) (uedge_set (concat fig_5))@@ -292,5 +296,5 @@  d_fig_5' :: [String] d_fig_5' =-    let pp = (const (Just ""),const Nothing,Just . ath_pp)-    in T.g_to_udot [("node:shape","point"),("edge:len","1.25")] pp d_fig_5_g'+    let pp = (\_ -> [("shape","")],\(_,e) -> [("label",ath_pp e)])+    in T.fgl_to_udot [("node:shape","point"),("edge:len","1.25")] pp d_fig_5_g'
+ Music/Theory/Z/Castren_1994.hs view
@@ -0,0 +1,153 @@+-- | Marcus Castrén.+--   /RECREL: A Similarity Measure for Set-Classes/.+--   PhD thesis, Sibelius Academy, Helsinki, 1994.+module Music.Theory.Z.Castren_1994 where++import Data.Int {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -}++import qualified Music.Theory.List as List+import Music.Theory.Z+import qualified Music.Theory.Z.Forte_1973 as Forte+import qualified Music.Theory.Z.SRO as SRO++type Z12 = Int8++-- | Is /p/ symmetrical under inversion.+--+-- > map inv_sym (Forte.scs_n 2) == [True,True,True,True,True,True]+-- > map (fromEnum.inv_sym) (Forte.scs_n 3) == [1,0,0,0,0,1,0,0,1,1,0,1]+inv_sym :: [Z12] -> Bool+inv_sym x = x `elem` map (\i -> sort (SRO.z_sro_tn z12 i (SRO.z_sro_invert z12 0 x))) [0..11]++-- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'.+--+-- > sc_t_ti [0,2,4] == Nothing+-- > sc_t_ti [0,1,3] == Just ([0,1,3],[0,2,3])+sc_t_ti :: [Z12] -> Maybe ([Z12], [Z12])+sc_t_ti p =+    if inv_sym p+    then Nothing+    else Just (p,Forte.z_t_prime z12 (SRO.z_sro_invert z12 0 p))++-- | Transpositional equivalence variant of Forte's 'sc_table'.  The+-- inversionally related classes are distinguished by labels @A@ and+-- @B@; the class providing the /best normal order/ (Forte 1973) is+-- always the @A@ class. If neither @A@ nor @B@ appears in the name of+-- a set-class, it is inversionally symmetrical.+--+-- > (length Forte.sc_table,length t_sc_table) == (224,352)+-- > lookup "5-Z18B" t_sc_table == Just [0,2,3,6,7]+t_sc_table :: [(Forte.SC_Name,[Z12])]+t_sc_table =+    let f x = let nm = Forte.sc_name x+              in case sc_t_ti x of+                   Nothing -> [(nm,x)]+                   Just (p,q) -> [(nm++"A",p),(nm++"B",q)]+    in concatMap f Forte.scs++-- | Lookup a set-class name.  The input set is subject to+-- 't_prime' before lookup.+--+-- > t_sc_name [0,2,3,6,7] == "5-Z18B"+-- > t_sc_name [0,1,4,6,7,8] == "6-Z17B"+t_sc_name :: [Z12] -> Forte.SC_Name+t_sc_name p =+    let n = find (\(_,q) -> Forte.z_t_prime z12 p == q) t_sc_table+    in fst (fromJust n)++-- | Lookup a set-class given a set-class name.+--+-- > t_sc "6-Z17A" == [0,1,2,4,7,8]+t_sc :: Forte.SC_Name -> [Z12]+t_sc n = snd (fromJust (find (\(m,_) -> n == m) t_sc_table))++-- | List of set classes.+t_scs :: [[Z12]]+t_scs = map snd t_sc_table++-- | Cardinality /n/ subset of 't_scs'.+--+-- > map (length . t_scs_n) [2..10] == [6,19,43,66,80,66,43,19,6]+t_scs_n :: Integral i => i -> [[Z12]]+t_scs_n n = filter ((== n) . genericLength) t_scs++-- | T-related /q/ that are subsets of /p/.+--+-- > t_subsets [0,1,2,3,4] [0,1]  == [[0,1],[1,2],[2,3],[3,4]]+-- > t_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4]]+-- > t_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6]]+t_subsets :: [Z12] -> [Z12] -> [[Z12]]+t_subsets x a = filter (`List.is_subset` x) (map sort (SRO.z_sro_t_related z12 a))++-- | T\/I-related /q/ that are subsets of /p/.+--+-- > ti_subsets [0,1,2,3,4] [0,1]  == [[0,1],[1,2],[2,3],[3,4]]+-- > ti_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4],[0,3,4]]+-- > ti_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6],[3,6,7]]+ti_subsets :: [Z12] -> [Z12] -> [[Z12]]+ti_subsets x a = filter (`List.is_subset` x) (nub (map sort (SRO.z_sro_ti_related z12 a)))++-- | Trivial run length encoder.+--+-- > rle "abbcccdde" == [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')]+rle :: (Eq a,Integral i) => [a] -> [(i,a)]+rle =+    let f x = (genericLength x,head x)+    in map f . group++-- | Inverse of 'rle'.+--+-- > rle_decode [(5,'a'),(4,'b')] == "aaaaabbbb"+rle_decode :: (Integral i) => [(i,a)] -> [a]+rle_decode =+    let f (i,j) = genericReplicate i j+    in concatMap f++-- | Length of /rle/ encoded sequence.+--+-- > rle_length [(5,'a'),(4,'b')] == 9+rle_length :: (Integral i) => [(i,a)] -> i+rle_length = sum . map fst++-- | T-equivalence /n/-class vector (subset-class vector, nCV).+--+-- > t_n_class_vector 2 [0..4] == [4,3,2,1,0,0]+-- > rle (t_n_class_vector 3 [0..4]) == [(1,3),(2,2),(2,1),(4,0),(1,1),(9,0)]+-- > rle (t_n_class_vector 4 [0..4]) == [(1,2),(3,1),(39,0)]+t_n_class_vector :: (Num a, Integral i) => i -> [Z12] -> [a]+t_n_class_vector n x =+    let a = t_scs_n n+    in map (genericLength . t_subsets x) a++-- | T\/I-equivalence /n/-class vector (subset-class vector, nCV).+--+-- > ti_n_class_vector 2 [0..4] == [4,3,2,1,0,0]+-- > ti_n_class_vector 3 [0,1,2,3,4] == [3,4,2,0,0,1,0,0,0,0,0,0]+-- > rle (ti_n_class_vector 4 [0,1,2,3,4]) == [(2,2),(1,1),(26,0)]+ti_n_class_vector :: (Num b, Integral i) => i -> [Z12] -> [b]+ti_n_class_vector n x =+    let a = Forte.scs_n n+    in map (genericLength . ti_subsets x) a++-- | 'icv' scaled by sum of /icv/.+--+-- > dyad_class_percentage_vector [0,1,2,3,4] == [40,30,20,10,0,0]+-- > dyad_class_percentage_vector [0,1,4,5,7] == [20,10,20,20,20,10]+dyad_class_percentage_vector :: Integral i => [Z12] -> [i]+dyad_class_percentage_vector p =+    let p' = Forte.z_icv z12 p+    in map (sum p' *) p'++-- | /rel/ metric.+--+-- > rel [0,1,2,3,4] [0,1,4,5,7] == 40+-- > rel [0,1,2,3,4] [0,2,4,6,8] == 60+-- > rel [0,1,4,5,7] [0,2,4,6,8] == 60+rel :: Integral i => [Z12] -> [Z12] -> Ratio i+rel x y =+    let x' = dyad_class_percentage_vector x+        y' = dyad_class_percentage_vector y+    in sum (map abs (zipWith (-) x' y')) % 2
Music/Theory/Z/Clough_1979.hs view
@@ -6,8 +6,9 @@  import qualified Music.Theory.List as T {- hmt -} --- type Z7 = Int-+-- | Shift sequence so the initial value is zero.+--+-- > transpose_to_zero [1,2,5] == [0,1,4] transpose_to_zero :: Num n => [n] -> [n] transpose_to_zero p =     case p of@@ -33,8 +34,10 @@ dpcset_complement p = filter (`notElem` p) z7_univ  -- | Interval class predicate (ie. 'is_z4').+--+-- > map is_ic [-1 .. 4] == [False,True,True,True,True,False] is_ic :: Integral n => n -> Bool-is_ic n = n >= 0 && n < 4+is_ic = is_z4  -- | Interval to interval class. --@@ -48,7 +51,7 @@ is_chord :: Integral n => [n] -> Bool is_chord = (== 7) . sum --- | Interval vector.+-- | Interval vector, given list of intervals. -- -- > iv [2,2,3] == [0,2,1] iv :: Integral n => [n] -> [n]@@ -97,20 +100,28 @@  -- * Z +-- | Is /n/ in (0,/m/ - 1). is_z_n :: Integral n => n -> n -> Bool is_z_n m n = n >= 0 && n < m -is_z4 :: Integral n => n -> Bool-is_z4 = is_z_n 4-+-- | Z /m/ universe, ie [0 .. m-1]. z_n_univ :: Integral n => n -> [n] z_n_univ m = [0 .. m - 1] +-- | 'is_z_n' of 4.+is_z4 :: Integral n => n -> Bool+is_z4 = is_z_n 4++-- | 'z_n_univ' of 7.+--+-- > z7_univ == [0 .. 6] z7_univ :: Integral n => [n] z7_univ = z_n_univ 7 +-- | 'is_z_n' of 7. is_z7 :: Integral n => n -> Bool is_z7 = is_z_n 7 +-- | 'mod' 7. mod7 :: Integral n => n -> n mod7 n = n `mod` 7
Music/Theory/Z/Drape_1999.hs view
@@ -1,18 +1,367 @@+-- | Haskell implementations of @pct@ operations.+-- See <http://rd.slavepianos.org/?t=pct> module Music.Theory.Z.Drape_1999 where +import Data.Function {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Set.List as T {- hmt -}+import qualified Music.Theory.Tuple as T {- hmt -} import Music.Theory.Z+import Music.Theory.Z.Forte_1973 import Music.Theory.Z.SRO import Music.Theory.Z.TTO -{- | Relate sets (TnMI).+-- | Cardinality filter+--+-- > cf [0,3] (cg [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]]+cf :: (Integral n) => [n] -> [[a]] -> [[a]]+cf ns = filter (\p -> genericLength p `elem` ns) +-- | Combinatorial sets formed by considering each set as possible+-- values for slot.+--+-- > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]]+-- > let n = "01" in cgg [n,n,n] == ["000","001","010","011","100","101","110","111"]+cgg :: [[a]] -> [[a]]+cgg l =+    case l of+      x:xs -> [ y:z | y <- x, z <- cgg xs ]+      _ -> [[]]++-- | Combinations generator, ie. synonym for 'powerset'.+--+-- > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]]+cg :: [a] -> [[a]]+cg = T.powerset++-- | Powerset filtered by cardinality.+--+-- >>> pct cg -r3 0159+-- 015+-- 019+-- 059+-- 159+--+-- > cg_r 3 [0,1,5,9] == [[0,1,5],[0,1,9],[0,5,9],[1,5,9]]+cg_r :: (Integral n) => n -> [a] -> [[a]]+cg_r n = cf [n] . cg++{- | Chain pcsegs.++>>> echo 024579 | pct chn T0 3 | sort -u+579468 (RT8M)+579A02 (T5)++> chn_t0 z12 3 [0,2,4,5,7,9] == [[5,7,9,10,0,2],[5,7,9,4,6,8]]++>>> echo 02457t | pct chn T0 2+7A0135 (RT5I)+7A81B9 (RT9MI)++> chn_t0 z12 2 [0,2,4,5,7,10] == [[7,10,0,1,3,5],[7,10,8,1,11,9]]++-}+chn_t0 :: Integral i => Z i -> Int -> [i] -> [[i]]+chn_t0 z n p =+    let f q = T.take_right n p == take n q+    in filter f (z_sro_rtmi_related z p)++{- | Cyclic interval segment.++>>> echo 014295e38t76 | pct cisg+13A7864529B6++> ciseg z12 [0,1,4,2,9,5,11,3,8,10,7,6] == [1,3,10,7,8,6,4,5,2,9,11,6]++-}+ciseg :: Integral i => Z i -> [i] -> [i]+ciseg z = T.d_dx_by (z_sub z) . cyc++-- | Synonynm for 'z_complement'.+--+-- >>> pct cmpl 02468t+-- 13579B+--+-- > cmpl z12 [0,2,4,6,8,10] == [1,3,5,7,9,11]+cmpl :: Integral i => Z i -> [i] -> [i]+cmpl = z_complement++-- | Form cycle.+--+-- >>> echo 056 | pct cyc+-- 0560+--+-- > cyc [0,5,6] == [0,5,6,0]+cyc :: [a] -> [a]+cyc l =+    case l of+      [] -> []+      x:xs -> (x:xs) ++ [x]++-- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor+-- set, 'o' for octotonic set.+d_nm :: (Integral a) => [a] -> Maybe Char+d_nm x =+    case x of+      [0,2,4,5,7,9,11] -> Just 'd'+      [0,2,3,5,7,9,11] -> Just 'm'+      [0,1,3,4,6,7,9,10] -> Just 'o'+      _ -> Nothing++-- | Diatonic implications.+dim :: Integral i => [i] -> [(i,[i])]+dim p =+    let g (i,q) = T.is_subset p (z_tto_tn z12 i q)+        f = filter g . zip [0..11] . repeat+        d = [0,2,4,5,7,9,11]+        m = [0,2,3,5,7,9,11]+        o = [0,1,3,4,6,7,9,10]+    in f d ++ f m ++ f o++-- | Variant of 'dim' that is closer to the 'pct' form.+--+-- >>> pct dim 016+-- T1d+-- T1m+-- T0o+--+-- > dim_nm [0,1,6] == [(1,'d'),(1,'m'),(0,'o')]+dim_nm :: Integral i => [i] -> [(i,Char)]+dim_nm =+    let pk f (i,j) = (i,f j)+    in nubBy ((==) `on` snd) .+       map (pk (fromMaybe (error "dim_mn") . d_nm)) .+       dim++-- | Diatonic interval set to interval set.+--+-- >>> pct dis 24+-- 1256+--+-- > dis [2,4] == [1,2,5,6]+dis :: (Integral t) => [Int] -> [t]+dis =+    let is = [[], [], [1,2], [3,4], [5,6], [6,7], [8,9], [10,11]]+    in concatMap (\j -> is !! j)++-- | Degree of intersection.+--+-- >>> echo 024579e | pct doi 6 | sort -u+-- 024579A+-- 024679B+--+-- > let p = [0,2,4,5,7,9,11]+-- > doi z12 6 p p == [[0,2,4,5,7,9,10],[0,2,4,6,7,9,11]]+--+-- >>> echo 01234 | pct doi 2 7-35 | sort -u+-- 13568AB+--+-- > doi z12 2 (sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]]+doi :: Integral i => Z i -> Int -> [i] -> [i] -> [[i]]+doi z n p q =+    let f j = [z_tto_tn z j p,z_tto_tni z j p]+        xs = concatMap f [0 .. z_modulus z - 1]+    in T.set (filter (\x -> length (x `intersect` q) == n) xs)++-- | Embedded segment search.+--+-- >>> echo 23A | pct ess 0164325+-- 2B013A9+-- 923507A+--+-- > ess z12 [0,1,6,4,3,2,5] [2,3,10] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]]+ess :: Integral i => Z i -> [i] -> [i] -> [[i]]+ess z p q = filter (`T.is_embedding` q) (z_sro_rtmi_related z p)++-- | Forte name (ie 'sc_name').+fn :: Integral i => [i] -> String+fn = sc_name++-- | Z-12 cycles.+frg_cyc :: Integral i => T.T6 [[i]]+frg_cyc =+    let add = z_add z12+        mul = z_mul z12+        c1 = [[0 .. 11]]+        c2 = map (\n -> map (add n) [0,2..10]) [0..1]+        c3 = map (\n -> map (add n) [0,3..9]) [0..2]+        c4 = map (\n -> map (add n) [0,4..8]) [0..3]+        c5 = map (map (mul 5)) c1+        c6 = map (\n -> map (add n) [0,6]) [0..5]+    in (c1,c2,c3,c4,c5,c6)++-- | Fragmentation of cycles.+frg :: Integral i =>  [i] -> T.T6 [String]+frg p =+    let f = map (\n -> if n `elem` p then z16_to_char n else '-')+    in T.t6_map (map f) frg_cyc++-- | Header sequence for 'frg_pp'.+frg_hdr :: [String]+frg_hdr = map (\n -> "Fragmentation of " ++ show n ++ "-cycle(s)") [1::Int .. 6]++{-| Fragmentation of cycles.++>>> pct frg 024579+Fragmentation of 1-cycle(s):  [0-2-45-7-9--]+Fragmentation of 2-cycle(s):  [024---] [--579-]+Fragmentation of 3-cycle(s):  [0--9] [-47-] [25--]+Fragmentation of 4-cycle(s):  [04-] [-59] [2--] [-7-]+Fragmentation of 5-cycle(s):  [05------4927]+Fragmentation of 6-cycle(s):  [0-] [-7] [2-] [-9] [4-] [5-]+IC cycle vector: <1> <22> <111> <1100> <5> <000000>++> putStrLn $ frg_pp [0,2,4,5,7,9]+-}+frg_pp :: Integral i => [i] -> String+frg_pp =+    let f = unwords . map (\p -> T.bracket ('[',']') p)+        g x y = x ++ ": " ++ y+    in unlines . zipWith g frg_hdr . T.t6_to_list . T.t6_map f . frg++-- | Can the set-class q (under prime form algorithm pf) be drawn from the pcset p.+has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool+has_sc_pf pf p q =+    let n = length q+    in pf q `elem` map pf (cf [n] (cg p))++-- | 'has_sc_pf' of 'forte_prime'+--+-- > let d = [0,2,4,5,7,9,11]+-- > has_sc z12 d (z_complement z12 d) == True+--+-- > has_sc z12 [] [] == True+has_sc :: Integral i => Z i -> [i] -> [i] -> Bool+has_sc z = has_sc_pf (z_forte_prime z)++-- | Interval-class cycle vector.+ic_cycle_vector :: Integral i => [i] -> T.T6 [Int]+ic_cycle_vector p =+    let f str = let str' = if length str > 2 then T.close 1 str else str+                in length (filter (\(x,y) -> x /= '-' && y /= '-') (T.adj2 1 str'))+    in T.t6_map (map f) (frg p)++-- | Pretty printer for 'ic_cycle_vector'.+--+-- > let r = "IC cycle vector: <1> <22> <111> <1100> <5> <000000>"+-- > ic_cycle_vector_pp (ic_cycle_vector [0,2,4,5,7,9]) == r+ic_cycle_vector_pp :: T.T6 [Int] -> String+ic_cycle_vector_pp = ("IC cycle vector: " ++) . unwords . T.t6_to_list . T.t6_map z16_seq_pp++-- | Interval cycle filter.+--+-- >>> echo 22341 | pct icf+-- 22341+--+-- > icf [[2,2,3,4,1]] == [[2,2,3,4,1]]+icf :: (Num a,Eq a) => [[a]] -> [[a]]+icf = filter ((== 12) . sum)++-- | Interval class set to interval sets.+--+-- >>> pct ici -c 123+-- 123+-- 129+-- 1A3+-- 1A9+--+-- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]+ici :: (Num t) => [Int] -> [[t]]+ici xs =+    let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j+        ys = map is xs+    in cgg ys++-- | Interval class set to interval sets, concise variant.+--+-- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]+ici_c :: [Int] -> [[Int]]+ici_c [] = []+ici_c (x:xs) = map (x:) (ici xs)++-- | Interval segment (INT).+iseg :: Integral i => Z i -> [i] -> [i]+iseg z = T.d_dx_by (z_sub z)++-- | Imbrications.+--+-- > let r = [[[0,2,4],[2,4,5],[4,5,7],[5,7,9]]+-- >         ,[[0,2,4,5],[2,4,5,7],[4,5,7,9]]]+-- > in imb [3,4] [0,2,4,5,7,9] == r+imb :: (Integral n) => [n] -> [a] -> [[[a]]]+imb cs p =+    let g n = (== n) . genericLength+        f ps n = filter (g n) (map (genericTake n) ps)+    in map (f (tails p)) cs++{- | 'issb' gives the set-classes that can append to 'p' to give 'q'.++>>> pct issb 3-7 6-32+3-7+3-2+3-11++> issb (sc "3-7") (sc "6-32") == ["3-2","3-7","3-11"]++-}+issb :: Integral i => [i] -> [i] -> [String]+issb p q =+    let k = length q - length p+        f = any id . map (\x -> z_forte_prime z12 (p ++ x) == q) . z_tto_ti_related z12+    in map sc_name (filter f (cf [k] scs))++-- | Matrix search.+--+-- >>> pct mxs 024579 642 | sort -u+-- 6421B9+-- B97642+--+-- > set (mxs z12 [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]]+mxs :: Integral i => Z i -> [i] -> [i] -> [[i]]+mxs z p q = filter (q `isInfixOf`) (z_sro_rti_related z p)++-- | Normalize (synonym for 'set')+--+-- >>> pct nrm 0123456543210+-- 0123456+--+-- > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6]+nrm :: (Ord a) => [a] -> [a]+nrm = T.set++-- | Normalize, retain duplicate elements.+nrm_r :: (Ord a) => [a] -> [a]+nrm_r = sort++{- | Pitch-class invariances (called @pi@ at @pct@).++>>> pct pi 0236 12+pcseg 0236+pcseg 6320+pcseg 532B+pcseg B235++> pci z12 [1,2] [0,2,3,6] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]]++-}+pci :: Integral i => Z i-> [Int] -> [i] -> [[i]]+pci z i p =+    let f q = T.set (map (q !!) i)+    in filter (\q -> f q == f p) (z_sro_rti_related z p)++{- | Relate sets (TnMI), ie 'z_tto_rel'+ >>> $ pct rs 0123 641B >>> T1M -> map tto_pp (rs 5 mod12 [0,1,2,3] [6,4,1,11]) == ["T1M","T4MI"]+> map tto_pp (rs 5 z12 [0,1,2,3] [6,4,1,11]) == ["T1M","T4MI"]+ -} rs :: Integral t => t -> Z t -> [t] -> [t] -> [TTO t]-rs = z_tto_rel+rs m z p q = z_tto_rel m z (T.set p) (T.set q)  {- | Relate segments. @@ -25,12 +374,205 @@ >>> $ pct rsg 0123 B614 >>> r3RT1M -> let sros = map sro_parse . words-> rsg 5 mod12 [1,5,6] [3,11,10] == sros "T4I r1RT4MI"-> rsg 5 mod12 [0,1,2,3] [0,5,10,3] == sros "T0M RT3MI"-> rsg 5 mod12 [0,1,2,3] [4,11,6,1] == sros "T4MI RT1M"-> rsg 5 mod12 [0,1,2,3] [11,6,1,4] == sros "r1T4MI r1RT1M"+> let sros = map (sro_parse 5) . words+> rsg 5 z12 [1,5,6] [3,11,10] == sros "T4I r1RT4MI"+> rsg 5 z12 [0,1,2,3] [0,5,10,3] == sros "T0M RT3MI"+> rsg 5 z12 [0,1,2,3] [4,11,6,1] == sros "T4MI RT1M"+> rsg 5 z12 [0,1,2,3] [11,6,1,4] == sros "r1T4MI r1RT1M"  -} rsg :: Integral i => i -> Z i -> [i] -> [i] -> [SRO i]-rsg m z x y = filter (\o -> z_sro_apply m z o x == y) (z_sro_univ (length x) z)+rsg m z x y = filter (\o -> z_sro_apply z o x == y) (z_sro_univ (length x) m z)++-- | Subsets.+--+-- > cf [4] (sb z12 [sc "6-32",sc "6-8"]) == [[0,2,3,5],[0,1,3,5],[0,2,3,7],[0,2,4,7],[0,2,5,7]]+sb :: Integral i => Z i -> [[i]] -> [[i]]+sb z xs =+    let f p = all id (map (\q -> has_sc z q p) xs)+    in filter f scs++{- | scc = set class completion++>>> pct scc 6-32 168+35A+49B+3AB+34B++> scc z12 (sc "6-32") [1,6,8] == [[3,5,10],[4,9,11],[3,10,11],[3,4,11]]++-}+scc :: Integral i => Z i -> [i] -> [i] -> [[i]]+scc z r p = map (\\ p) (filter (T.is_subset p) (z_tto_ti_related z r))++-- | Header fields for 'si'.+si_hdr :: [String]+si_hdr =+    ["pitch-class-set"+    ,"set-class"+    ,"interval-class-vector"+    ,"tics"+    ,"complement"+    ,"multiplication-by-five-transform"]++-- | (PCSET,TTO,FORTE-PRIME)+type SI i = ([i],TTO i,[i])++-- | Calculator for si.+--+-- > si_calc z12 [0,5,3,11]+si_calc :: Integral i => [i] -> (SI i,[i],[Int],SI i,SI i)+si_calc p =+    let n = length p+        p_icv = fromIntegral n : z_icv z12 p+        gen_si x = let x_f = z_forte_prime z12 x+                       x_o:_ = rs 5 z12 x_f x+                   in (nub (sort x),x_o,x_f)+    in (gen_si p,p_icv,tics z12 p,gen_si (z_complement z12 p),gen_si (map (z_mul z12 5) p))++-- | Pretty printer for RHS for si.+--+-- > si_rhs_pp z12 [0,5,3,11]+si_rhs_pp :: (Integral i,Show i) => [i] -> [String]+si_rhs_pp p =+    let pf_pp concise (x_o,x_f) =+            concat [tto_pp x_o," ",sc_name x_f+                   ,if concise then "" else z16_vec_pp x_f]+        si_pp (x,x_o,x_f) = concat [z16_set_pp x," (",pf_pp True (x_o,x_f),")"]+        ((p',p_o,p_f),p_icv,p_tics,c,m) = si_calc p+    in [z16_set_pp p'+       ,pf_pp False (p_o,p_f)+       ,z16_vec_pp p_icv+       ,z16_vec_pp p_tics+       ,si_pp c+       ,si_pp m]++{- | Set information.++$ pct si 053b+pitch-class-set: {035B}+set-class: TB  4-Z15[0146]+interval-class-vector: [4111111]+tics: [102222102022]+complement: {1246789A} (TAI 8-Z15)+multiplication-by-five-transform: {0317} (T0  4-Z29)+$++> putStr $ unlines $ si [0,5,3,11]+-}+si :: (Integral i,Show i) => [i] -> [String]+si p = zipWith (\k v -> concat [k,": ",v]) si_hdr (si_rhs_pp p)++{- | Super set-class.++>>> pct spsc 4-11 4-12+5-26[02458]++> spsc z12 [sc "4-11",sc "4-12"] == [[0,2,4,5,8]]++>>> pct spsc 3-11 3-8+4-27[0258]+4-Z29[0137]++> spsc z12 [sc "3-11",sc "3-8"] == [[0,2,5,8],[0,1,3,7]]++>>> pct spsc `pct fl 3`+6-Z17[012478]++> spsc z12 (cf [3] scs) == [[0,1,2,4,7,8]]++-}+spsc :: Integral i => Z i -> [[i]] -> [[i]]+spsc z xs =+    let f y = all (has_sc z y) xs+        g = (==) `on` length+    in (head . groupBy g . filter f) scs++{- | sra = stravinsky rotational array++>>> echo 019BA7 | pct sra+019BA7+08A96B+021A34+0B812A+0923B1+056243++> let r = [[0,1,9,11,10,7],[0,8,10,9,6,11],[0,2,1,10,3,4],[0,11,8,1,2,10],[0,9,2,3,11,1],[0,5,6,2,4,3]]+> sra z12 [0,1,9,11,10,7] == r++-}+sra :: Integral i => Z i -> [i] -> [[i]]+sra z = map (z_sro_tn_to z 0) . T.rotations++{- | Serial operation.++>>> echo 156 | pct sro T4+59A++> sro (Z.sro_parse "T4") [1,5,6] == [5,9,10]++>>> echo 024579 | pct sro RT4I+79B024++> sro (Z.SRO 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4]++>>> echo 156 | pct sro T4I+3BA++> sro (Z.sro_parse "T4I") [1,5,6] == [3,11,10]+> sro (Z.SRO 0 False 4 False True) [1,5,6] == [3,11,10]++>>> echo 156 | pct sro T4  | pct sro T0I+732++> (sro (Z.sro_parse "T0I") . sro (Z.sro_parse "T4")) [1,5,6] == [7,3,2]++>>> echo 024579 | pct sro RT4I+79B024++> sro (Z.sro_parse "RT4I") [0,2,4,5,7,9] == [7,9,11,0,2,4]++-}+sro :: Integral i => Z i -> SRO i -> [i] -> [i]+sro z o = z_sro_apply z o++{- | tmatrix++>>> pct tmatrix 1258++1258+0147+9A14+67A1++> tmatrix z12 [1,2,5,8] == [[1,2,5,8],[0,1,4,7],[9,10,1,4],[6,7,10,1]]++-}+tmatrix :: Integral i => Z i -> [i] -> [[i]]+tmatrix z p =+    let i = map (z_negate z) (T.d_dx_by (z_sub z) p)+    in map (\n -> map (z_add z n) p) (T.dx_d 0 i)+++{- | trs = transformations search.  Search all RTnMI of /p/ for /q/.++>>> echo 642 | pct trs 024579 | sort -u+531642+6421B9+642753+B97642++> let r = [[5,3,1,6,4,2],[6,4,2,1,11,9],[6,4,2,7,5,3],[11,9,7,6,4,2]]+> sort (trs z12 [0,2,4,5,7,9] [6,4,2]) == r++-}+trs :: Integral i => Z i -> [i] -> [i] -> [[i]]+trs z p q = filter (q `isInfixOf`) (z_sro_rtmi_related z p)++-- | Like 'trs', but of 'z_sro_rti_related'.+--+-- > trs_m z12 [0,2,4,5,7,9] [6,4,2] == [[6,4,2,1,11,9],[11,9,7,6,4,2]]+trs_m :: Integral i => Z i -> [i] -> [i] -> [[i]]+trs_m z p q = filter (q `isInfixOf`) (z_sro_rti_related z p)
Music/Theory/Z/Forte_1973.hs view
@@ -1,5 +1,5 @@--- | Allen Forte. /The Structure of Atonal Music/. Yale University--- Press, New Haven, 1973.+-- | Allen Forte. /The Structure of Atonal Music/.+--   Yale University Press, New Haven, 1973. module Music.Theory.Z.Forte_1973 where  import Data.List {- base -}@@ -14,35 +14,30 @@  -- * Prime form --- | T-related rotations of /p/.+-- | T-related rotations of /p/, ie. all rotations tranposed to be at zero. ----- > t_rotations mod12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]]-t_rotations :: Integral i => Z i -> [i] -> [[i]]-t_rotations z p =+-- > z_t_rotations z12 [1,2,4] == [[0,1,3],[0,2,11],[0,9,10]]+z_t_rotations :: Integral i => Z i -> [i] -> [[i]]+z_t_rotations z p =     let r = T.rotations (sort p)     in map (z_sro_tn_to z 0) r  -- | T\/I-related rotations of /p/. ----- > ti_rotations mod12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]--- >                               ,[0,9,11],[0,2,3],[0,1,10]]-ti_rotations :: Integral i => Z i -> [i] -> [[i]]-ti_rotations z p =+-- > ti_rotations z12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10],[0,9,11],[0,2,3],[0,1,10]]+z_ti_rotations :: Integral i => Z i -> [i] -> [[i]]+z_ti_rotations z p =     let q = z_sro_invert z 0 p         r = T.rotations (sort p) ++ T.rotations (sort q)     in map (z_sro_tn_to z 0) r --- | Variant with default value for empty input list case.-minimumBy_or :: t -> (t -> t -> Ordering) -> [t] -> t-minimumBy_or p f q = if null q then p else minimumBy f q- -- | Prime form rule requiring comparator, considering 't_rotations'.-t_cmp_prime :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i]-t_cmp_prime z f = minimumBy_or [] f . t_rotations z+z_t_cmp_prime :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i]+z_t_cmp_prime z f = T.minimumBy_or [] f . z_t_rotations z  -- | Prime form rule requiring comparator, considering 'ti_rotations'.-ti_cmp_prime :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i]-ti_cmp_prime z f = minimumBy_or [] f . ti_rotations z+z_ti_cmp_prime :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i]+z_ti_cmp_prime z f = T.minimumBy_or [] f . z_ti_rotations z  -- | Forte comparison function (rightmost first then leftmost outwards). --@@ -56,44 +51,51 @@       _ -> let r = compare (last p) (last q)            in if r == EQ then compare p q else r --- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'.------ > forte_prime mod12 [0,1,3,6,8,9] == [0,1,3,6,8,9]--- > forte_prime mod5 [0,1,4] == [0,1,2]------ > S.set (map (forte_prime mod5) (S.powerset [0..4]))--- > S.set (map (forte_prime mod7) (S.powerset [0..6]))-forte_prime :: Integral i => Z i -> [i] -> [i]-forte_prime z = ti_cmp_prime z forte_cmp+{- | Forte prime form, ie. 'z_ti_cmp_prime' of 'forte_cmp'. --- | Transpositional equivalence prime form, ie. 't_cmp_prime' of--- 'forte_cmp'.+> z_forte_prime z12 [0,1,3,6,8,9] == [0,1,3,6,8,9]+> z_forte_prime z5 [0,1,4] == [0,1,2]++> S.set (map (z_forte_prime z5) (S.powerset [0..4]))+> S.set (map (z_forte_prime z7) (S.powerset [0..6]))+-}+z_forte_prime :: Integral i => Z i -> [i] -> [i]+z_forte_prime z x =+  if nub x /= x || map (z_mod z) x /= x+  then error "z_forte_prime: invalid input"+  else z_ti_cmp_prime z forte_cmp x++-- | Transpositional equivalence prime form,+--   ie. 'z_t_cmp_prime' of 'forte_cmp'. ----- > (forte_prime mod12 [0,2,3],t_prime mod12 [0,2,3]) == ([0,1,3],[0,2,3])-t_prime :: Integral i => Z i -> [i] -> [i]-t_prime z = t_cmp_prime z forte_cmp+-- > (z_forte_prime z12 [0,2,3],z_t_prime z12 [0,2,3]) == ([0,1,3],[0,2,3])+z_t_prime :: Integral i => Z i -> [i] -> [i]+z_t_prime z = z_t_cmp_prime z forte_cmp  -- * ICV Metric  -- | Interval class of interval /i/. ----- > map (ic 12) [0..11] == [0,1,2,3,4,5,6,5,4,3,2,1]--- > map (ic 7) [0..6] == [0,1,2,3,3,2,1]--- > map (ic 5) [1,2,3,4] == [1,2,2,1]--- > map (ic 12) [5,6,7] == [5,6,5]--- > map (ic 12 . to_Z mod12) [-13,-1,0,1,13] == [1,1,0,1,1]-ic :: Integral i => i -> i -> i-ic z i = if i <= (z `div` 2) then i else z - i+-- > map (z_ic z12) [0..12] == [0,1,2,3,4,5,6,5,4,3,2,1,0]+-- > map (z_ic z7) [0..7] == [0,1,2,3,3,2,1,0]+-- > map (z_ic z5) [0..5] == [0,1,2,2,1,0]+-- > map (z_ic z12) [5,6,7] == [5,6,5]+-- > map (z_ic z12) [-13,-1,0,1,13] == [1,1,0,1,1]+z_ic :: Integral i => Z i -> i -> i+z_ic z i =+  let j = z_mod z i+      m = z_modulus z+  in if j <= (m `div` 2) then j else m - j  -- | Forte notation for interval class vector. ----- > icv 12 [0,1,2,4,7,8] == [3,2,2,3,3,2]-icv :: (Integral i, Num n) => i -> [i] -> [n]-icv z s =-    let i = map (ic z . flip mod z . uncurry (-)) (S.pairs s)+-- > z_icv z12 [0,1,2,4,7,8] == [3,2,2,3,3,2]+z_icv :: (Integral i, Num n) => Z i -> [i] -> [n]+z_icv z s =+    let i = map (z_ic z . z_mod z . uncurry (-)) (S.pairs s)         f l = (head l,genericLength l)         j = map f (group (sort i))-        k = map (`lookup` j) [1 .. z `div` 2]+        k = map (`lookup` j) [1 .. z_modulus z `div` 2]     in map (fromMaybe 0) k  -- * BIP Metric@@ -104,43 +106,36 @@ -- >>> bip 0t95728e3416 -- 11223344556 ----- > bip 12 [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6]-bip :: Integral a => a -> [a] -> [a]-bip z = sort . map (ic z . flip mod z) . T.d_dx---- * Name+-- > z_bip z12 [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6]+z_bip :: Integral i => Z i -> [i] -> [i]+z_bip z = sort . map (z_ic z . z_mod z) . T.d_dx  {- | Generate SC universe, though not in order of the Forte table. -> let r = [[]->         ,[0]->         ,[0,1],[0,2],[0,3]->         ,[0,1,2],[0,1,3],[0,1,4],[0,2,4]->         ,[0,1,2,3],[0,1,2,4],[0,1,3,4],[0,1,3,5]->         ,[0,1,2,3,4],[0,1,2,3,5],[0,1,2,4,5]->         ,[0,1,2,3,4,5]->         ,[0,1,2,3,4,5,6]]-> in sc_univ mod7 == r--> sort (sc_univ mod12) == sort (map snd sc_table)--> zipWith (\p q -> (p == q,p,q)) (sc_univ mod12) (map snd sc_table)+> length (z_sc_univ z7) == 18+> sort (z_sc_univ z12) == sort (map snd sc_table)+> zipWith (\p q -> (p == q,p,q)) (z_sc_univ z12) (map snd sc_table)  -}-sc_univ :: Integral i => Z i -> [[i]]-sc_univ z =-    T.sort_by_two_stage length id $+z_sc_univ :: Integral i => Z i -> [[i]]+z_sc_univ z =+    T.sort_by_two_stage_on length id $     nub $-    map (forte_prime z) $+    map (z_forte_prime z) $     S.powerset (z_univ z) +-- * Forte Names (Z12)+ -- | Synonym for 'String'. type SC_Name = String --- | The set-class table (Forte prime forms).+-- | Table of (SC-NAME,PCSET).+type SC_Table n = [(SC_Name,[n])]++-- | The Z12 set-class table (Forte prime forms). -- -- > length sc_table == 224-sc_table :: Num n => [(SC_Name,[n])]+sc_table :: Num n => SC_Table n sc_table =     [("0-1",[])     ,("1-1",[0])@@ -368,7 +363,7 @@     ,("12-1",[0,1,2,3,4,5,6,7,8,9,10,11])]  -- | Unicode (non-breaking hyphen) variant.-sc_table_unicode :: Num n => [(SC_Name,[n])]+sc_table_unicode :: Num n => SC_Table n sc_table_unicode =     let f = map (\c -> if c == '-' then non_breaking_hypen else c)     in map (\(nm,pc) -> (f nm,pc)) sc_table@@ -380,34 +375,37 @@ forte_prime_name :: (Num n,Eq n) => [n] -> (SC_Name,[n]) forte_prime_name p = fromMaybe (error "forte_prime_name") (find (\(_,q) -> p == q) sc_table) -sc_tbl_lookup :: Integral i => Z i -> [(SC_Name,[i])] -> [i] -> Maybe (SC_Name,[i])-sc_tbl_lookup z tbl p = find (\(_,q) -> forte_prime z p == q) tbl+-- | Lookup entry for set in table.+sc_tbl_lookup :: Integral i => SC_Table i -> [i] -> Maybe (SC_Name,[i])+sc_tbl_lookup tbl p = find (\(_,q) -> z_forte_prime z12 p == q) tbl -sc_tbl_lookup_err :: Integral i => Z i -> [(SC_Name,[i])] -> [i] -> (SC_Name,[i])-sc_tbl_lookup_err z tbl = fromMaybe (error "sc_tbl_lookup") . sc_tbl_lookup z tbl+-- | Erroring variant+sc_tbl_lookup_err :: Integral i => SC_Table i -> [i] -> (SC_Name,[i])+sc_tbl_lookup_err tbl = fromMaybe (error "sc_tbl_lookup") . sc_tbl_lookup tbl -sc_name' :: Integral i => Z i -> [(SC_Name,[i])] -> [i] -> SC_Name-sc_name' z tbl = fst . sc_tbl_lookup_err z tbl+-- | 'fst' of 'sc_tbl_lookup_err'+sc_name_tbl :: Integral i => SC_Table i -> [i] -> SC_Name+sc_name_tbl tbl = fst . sc_tbl_lookup_err tbl  -- | Lookup a set-class name.  The input set is subject to--- 'forte_prime' before lookup.+-- 'forte_prime' of 'z12' before lookup. ----- > sc_name mod12 [0,2,3,6,7] == "5-Z18"--- > sc_name mod12 [0,1,4,6,7,8] == "6-Z17"-sc_name :: Integral i => Z i -> [i] -> SC_Name-sc_name z = sc_name' z sc_table+-- > sc_name [0,2,3,6,7] == "5-Z18"+-- > sc_name [0,1,4,6,7,8] == "6-Z17"+sc_name :: Integral i => [i] -> SC_Name+sc_name = sc_name_tbl sc_table  -- | Long name (ie. with enumeration of prime form). ----- > sc_name_long mod12 [0,1,4,6,7,8] == "6-Z17[012478]"-sc_name_long :: Integral i => Z i -> [i] -> SC_Name-sc_name_long z p =-    let (nm,p') = sc_tbl_lookup_err z sc_table p+-- > sc_name_long [0,1,4,6,7,8] == "6-Z17[012478]"+sc_name_long :: Integral i => [i] -> SC_Name+sc_name_long p =+    let (nm,p') = sc_tbl_lookup_err sc_table p     in nm ++ z16_vec_pp p'  -- | Unicode (non-breaking hyphen) variant.-sc_name_unicode :: Integral i => Z i -> [i] -> SC_Name-sc_name_unicode z = sc_name' z sc_table_unicode+sc_name_unicode :: Integral i => [i] -> SC_Name+sc_name_unicode = sc_name_tbl sc_table_unicode  -- | Lookup a set-class given a set-class name. --@@ -415,6 +413,7 @@ sc :: Num n => SC_Name -> [n] sc n = snd (fromMaybe (error "sc") (find (\(m,_) -> n == m) sc_table)) +-- | The set-class table (Forte prime forms), ie. 'snd' of 'sc_table'. scs :: Num n => [[n]] scs = map snd sc_table @@ -426,7 +425,8 @@  -- | Vector indicating degree of intersection with inversion at each transposition. ----- > tics mod12 [0,2,4,5,7,9] == [3,2,5,0,5,2,3,4,1,6,1,4]+-- > tics z12 [0,2,4,5,7,9] == [3,2,5,0,5,2,3,4,1,6,1,4]+-- > map (tics z12) scs tics :: Integral i => Z i -> [i] -> [Int] tics z p =     let q = z_sro_t_related z (z_sro_invert z 0 p)@@ -436,13 +436,13 @@  -- | Locate /Z/ relation of set class. ----- > fmap (sc_name mod12) (z_relation_of 12 (sc "7-Z12")) == Just "7-Z36"-z_relation_of :: Integral i => i -> [i] -> Maybe [i]-z_relation_of z x =+-- > fmap sc_name (z_relation_of (sc "7-Z12")) == Just "7-Z36"+z_relation_of :: Integral i => [i] -> Maybe [i]+z_relation_of x =     let n = length x         eq_i :: [Integer] -> [Integer] -> Bool         eq_i = (==)-        f y = (x /= y) && (icv z x `eq_i` icv z y)+        f y = (x /= y) && (z_icv z12 x `eq_i` z_icv z12 y)     in case filter f (scs_n n) of          [] -> Nothing          [r] -> Just r
+ Music/Theory/Z/Lewin_1980.hs view
@@ -0,0 +1,50 @@+-- | David Lewin. \"A Response to a Response: On PC Set+-- Relatedness\". /Perspectives of New Music/, 18(1-2):498-502, 1980.+module Music.Theory.Z.Lewin_1980 where++import Data.Int {- base -}+import Data.List {- base -}++import qualified Music.Theory.Z.Castren_1994 as Castren++type Z12 = Int8++-- | REL function with given /ncv/ function (see 't_rel' and 'ti_rel').+rel :: Floating n => (Int -> [a] -> [n]) -> [a] -> [a] -> n+rel ncv x y =+    let n = min (genericLength x) (genericLength y)+        p = map (`ncv` x) [2..n]+        q = map (`ncv` y) [2..n]+        f = zipWith (\i j -> sqrt (i * j))+        pt = sum (map sum p)+        qt = sum (map sum q)+    in sum (map sum (zipWith f p q)) / sqrt (pt * qt)++-- | T-equivalence REL function.+--+-- Kuusi 2001, 7.5.2+--+-- > let (~=) p q = abs (p - q) < 0.001+-- > t_rel [0,1,2,3,4] [0,2,3,6,7] ~= 0.429+-- > t_rel [0,1,2,3,4] [0,2,4,6,8] ~= 0.253+-- > t_rel [0,2,3,6,7] [0,2,4,6,8] ~= 0.324+t_rel :: Floating n => [Z12] -> [Z12] -> n+t_rel = rel Castren.t_n_class_vector++-- | T/I-equivalence REL function.+--+-- Buchler 1998, Fig. 3.38+--+-- > let (~=) p q = abs (p - q) < 0.001+-- > let a = [0,2,3,5,7]::[Z12]+-- > let b = [0,2,3,4,5,8]::[Z12]+-- > let g = [0,1,2,3,5,6,8,10]::[Z12]+-- > let j = [0,2,3,4,5,6,8]::[Z12]+-- > ti_rel a b ~= 0.593+-- > ti_rel a g ~= 0.648+-- > ti_rel a j ~= 0.509+-- > ti_rel b g ~= 0.712+-- > ti_rel b j ~= 0.892+-- > ti_rel g j ~= 0.707+ti_rel :: Floating n => [Z12] -> [Z12] -> n+ti_rel = rel Castren.ti_n_class_vector
+ Music/Theory/Z/Literature.hs view
@@ -0,0 +1,48 @@+-- | Z12 set class database.+module Music.Theory.Z.Literature where++-- | Set class database with descriptors for historically and+-- theoretically significant set classes, indexed by Forte name.+--+-- > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord"+-- > lookup "7-35" sc_db == Just "diatonic collection (d)"+sc_db :: [(String,String)]+sc_db =+    [("4-Z15","All-Interval Tetrachord (see also 4-Z29)")+    ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)")+    ,("6-Z17","All-Trichord Hexachord")+    ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)")+    ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)")+    ,("6-1","A-Type All-Combinatorial Hexachord")+    ,("6-8","B-Type All-Combinatorial Hexachord")+    ,("6-32","C-Type All-Combinatorial Hexachord")+    ,("6-7","D-Type All-Combinatorial Hexachord")+    ,("6-20","E-Type All-Combinatorial Hexachord")+    ,("6-35","F-Type All-Combinatorial Hexachord")+    ,("7-35","diatonic collection (d)")+    ,("7-34","ascending melodic minor collection")+    ,("8-28","octotonic collection (Messiaen Mode II)")+    ,("6-35","wholetone collection")+    ,("3-10","diminished triad")+    ,("3-11","major/minor triad")+    ,("3-12","augmented triad")+    ,("4-19","minor major-seventh chord")+    ,("4-20","major-seventh chord")+    ,("4-25","french augmented sixth chord")+    ,("4-28","dimished-seventh chord")+    ,("4-26","minor-seventh chord")+    ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord")+    ,("6-30","Petrushka Chord {0476a1},3-11 at T6")+    ,("6-34","Mystic Chord {06a492}")+    ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7")+    ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB")+    ,("9-12","Messiaen Mode III (nontonic collection)")+    ,("8-9","Messian Mode IV")+    ,("7-31","The only seven-element subset of 8-28. ")+    ,("5-31","The only five-element superset of 4-28.")+    ,("5-33","The only five-element subset of 6-35.")+    ,("7-33","The only seven-element superset of 6-35.")+    ,("5-21","The only five-element subset of 6-20.")+    ,("7-21","The only seven-element superset of 6-20.")+    ,("5-25","The only five-element subset of both 7-35 and 8-28.")+    ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ]
+ Music/Theory/Z/Morris_1974.hs view
@@ -0,0 +1,47 @@+-- | Robert Morris and D. Starr. \"The Structure of All-Interval Series\".+-- /Journal of Music Theory/, 18:364-389, 1974.+module Music.Theory.Z.Morris_1974 where++import qualified Control.Monad.Logic as L {- logict -}++-- | 'L.msum' '.' 'map' 'return'.+--+-- > L.observeAll (fromList [1..7]) == [1..7]+fromList :: L.MonadPlus m => [a] -> m a+fromList = L.msum . map return++-- | Interval from /i/ to /j/ in modulo-/n/.+--+-- > let f = int_n 12 in (f 0 11,f 11 0) == (11,1)+int_n :: Integral a => a -> a -> a -> a+int_n n i j = abs ((j - i) `mod` n)++-- | 'L.MonadLogic' all-interval series.+--+-- > map (length . L.observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288]+-- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` L.observeAll (all_interval_m 12)+-- > length (L.observeAll (all_interval_m 12)) == 3856+all_interval_m :: L.MonadLogic m => Int -> m [Int]+all_interval_m n =+    let recur k p q = -- k = length p, p = pitch-class sequence, q = interval set+            if k == n+            then return (reverse p)+            else do i <- fromList [1 .. n - 1]+                    L.guard (i `notElem` p)+                    let j:_ = p+                        m = int_n n i j+                    L.guard (m `notElem` q)+                    recur (k + 1) (i : p) (m : q)+    in recur 1 [0] []++{- | 'L.observeAll' of 'all_interval_m'.++> let r = [[0,1,5,2,4,3],[0,2,1,4,5,3],[0,4,5,2,1,3],[0,5,1,4,2,3]]+> all_interval 6 == r++> d_dx_n n l = zipWith (int_n n) l (tail l)+> map (d_dx_n 6) r == [[1,4,3,2,5],[2,5,3,1,4],[4,1,3,5,2],[5,2,3,4,1]]++-}+all_interval :: Int -> [[Int]]+all_interval = L.observeAll . all_interval_m
+ Music/Theory/Z/Morris_1987.hs view
@@ -0,0 +1,12 @@+-- | Robert Morris. /Composition with Pitch-Classes: A Theory of+-- Compositional Design/. Yale University Press, New Haven, 1987.+module Music.Theory.Z.Morris_1987 where++import Music.Theory.List {- hmt -}+import Music.Theory.Z {- hmt -}++-- | @INT@ operator.+--+-- > map (int z12) [[0,1,3,6,10],[3,7,0]] == [[1,2,3,4],[4,5]]+int :: Integral i => Z i -> [i] -> [i]+int z = d_dx_by (z_sub z)
+ Music/Theory/Z/Morris_1987/Parse.hs view
@@ -0,0 +1,19 @@+-- | Parsers for pitch class sets and sequences, and for 'SRO's.+module Music.Theory.Z.Morris_1987.Parse where++import Data.Char {- base -}++-- | Parse a /pitch class object/ string.  Each 'Char' is either a+-- number, a space which is ignored, or a letter name for the numbers+-- 10 ('t' or 'a' or 'A') or 11 ('e' or 'B' or 'b').+--+-- > pco "13te" == [1,3,10,11]+-- > pco "13te" == pco "13ab"+pco :: Num n => String -> [n]+pco s =+    let s' = dropWhile isSpace s+        s'' = takeWhile (`elem` "0123456789taAebB") s'+        f c | c `elem` "taA" = 10+            | c `elem` "ebB" = 11+            | otherwise = fromInteger (read [c])+    in map f s''
+ Music/Theory/Z/Rahn_1980.hs view
@@ -0,0 +1,29 @@+-- | John Rahn. /Basic Atonal Theory/. Longman, New York, 1980.+module Music.Theory.Z.Rahn_1980 where++import qualified Music.Theory.Z.Forte_1973 as Forte_1973 {- hmt -}+import Music.Theory.Z {- hmt -}++-- | Rahn prime form (comparison is rightmost inwards).+--+-- > rahn_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == GT+rahn_cmp :: Ord a => [a] -> [a] -> Ordering+rahn_cmp p q = compare (reverse p) (reverse q)++-- | Rahn prime form, ie. 'Forte_1973.ti_cmp_prime' of 'rahn_cmp'.+--+-- > z_rahn_prime z12 [0,1,3,6,8,9] == [0,2,3,6,7,9]+z_rahn_prime :: Integral i => Z i -> [i] -> [i]+z_rahn_prime z = Forte_1973.z_ti_cmp_prime z rahn_cmp++-- | The six sets where the Forte and Rahn prime forms differ.+--   Given here in Forte prime form.+--+-- > all (\p -> Forte_1973.forte_prime z12 p /= rahn_prime z12 p) rahn_forte_diff == True+rahn_forte_diff :: Num n => [[n]]+rahn_forte_diff =+  [[0,1,3,7,8] -- #5+  ,[0,1,3,5,8,9],[0,1,3,6,8,9] -- #6+  ,[0,1,2,4,7,8,9],[0,1,2,3,5,8,9] -- #7+  ,[0,1,2,4,5,7,9,10] -- #8+  ]
Music/Theory/Z/Read_1978.hs view
@@ -7,84 +7,99 @@ import Data.Char {- base -} import Data.List {- base -} import Data.Maybe {- base -}--import qualified Music.Theory.List as T {- hmt -}+import Data.Word {- base -} +import qualified Music.Theory.List as List {- hmt -} import qualified Music.Theory.Z as Z {- hmt -}-import qualified Music.Theory.Z.SRO as Z {- hmt -}+import qualified Music.Theory.Z.SRO as SRO {- hmt -}  -- | Coding.-type Code = Int+type Code = Word64 +-- | Number of bits at 'Code'.+code_len :: Num n => n+code_len = 64+ -- | Bit array.-type Array = [Bool]+type Bit_Array = [Bool] --- | Pretty printer for 'Array'.-array_pp :: Array -> String-array_pp = map intToDigit . map fromEnum+-- | Logical complement.+bit_array_complement :: Bit_Array -> Bit_Array+bit_array_complement = map not --- | Parse PP of 'Array'.+-- | Pretty printer for 'Bit_Array'.+bit_array_pp :: Bit_Array -> String+bit_array_pp = map intToDigit . map fromEnum++-- | Parse PP of 'Bit_Array'. ----- > parse_array "01001" == [False,True,False,False,True]-parse_array :: String -> Array-parse_array = map (toEnum . digitToInt)+-- > bit_array_parse "01001" == [False,True,False,False,True]+bit_array_parse :: String -> Bit_Array+bit_array_parse = map (toEnum . digitToInt) --- | Generate 'Code' from 'Array', the coding is most to least significant.+-- * MSB (BIG-ENDIAN)++-- | Generate 'Code' from 'Bit_Array', the coding is most to least significant. ----- > array_to_code (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == 6428-array_to_code :: Array -> Code-array_to_code a =-    let n = length a-        f e j = if e then 2 ^ (n - j - 1) else 0-    in sum (zipWith f a [0..])+-- > map (bit_array_to_code . bit_array_parse) (words "000 001 010 011 100 101 110 111") == [0..7]+-- > bit_array_to_code (bit_array_parse "1100100011100") == 6428+bit_array_to_code :: Bit_Array -> Code+bit_array_to_code a =+  let n = length a+      f e j = if e then 2 ^ (n - j - 1) else 0+  in if n > code_len+     then error "bit_array_to_code: > SZ"+     else sum (zipWith f a [0..]) --- | Inverse of 'array_to_code'.+-- | Inverse of 'bit_array_to_code'. ----- > code_to_array 13 6428 == map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]-code_to_array :: Int -> Code -> Array-code_to_array n c = map (testBit c) [n - 1, n - 2 .. 0]+-- > code_to_bit_array 13 6428 == bit_array_parse "1100100011100"+code_to_bit_array :: Int -> Code -> Bit_Array+code_to_bit_array n c =+  if n > code_len+  then error "code_to_bit_array: > SZ"+  else map (testBit c) [n - 1, n - 2 .. 0] --- | Array to set.+-- | 'Bit_Array' to set. ----- > array_to_set (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == [0,1,4,8,9,10]--- > encode [0,1,4,8,9,10] == 1811-array_to_set :: Integral i => [Bool] -> [i]-array_to_set =+-- > bit_array_to_set (bit_array_parse "1100100011100") == [0,1,4,8,9,10]+-- > set_to_code 13 [0,1,4,8,9,10] == 6428+bit_array_to_set :: Integral i => Bit_Array -> [i]+bit_array_to_set =     let f (i,e) = if e then Just i else Nothing     in mapMaybe f . zip [0..] --- | Inverse of 'array_to_set', /z/ is the degree of the array.-set_to_array :: Integral i => i -> [i] -> Array-set_to_array z p = map (`elem` p) [0 .. z - 1]+-- | Inverse of 'bit_array_to_set', /z/ is the degree of the array.+set_to_bit_array :: Integral i => i -> [i] -> Bit_Array+set_to_bit_array z p =+  if z > code_len+  then error "set_to_bit_array: > SZ"+  else map (`elem` p) [0 .. z - 1] --- | 'array_to_code' of 'set_to_array'.+-- | 'bit_array_to_code' of 'set_to_bit_array'. -- -- > set_to_code 12 [0,2,3,5] == 2880--- > map (set_to_code 12) (T.z_ti_related (flip mod 12) [0,2,3,5])+-- > map (set_to_code 12) (SRO.z_sro_ti_related (flip mod 12) [0,2,3,5]) set_to_code :: Integral i => i -> [i] -> Code-set_to_code z = array_to_code . set_to_array z---- | Logical complement.-array_complement :: Array -> Array-array_complement = map not+set_to_code z = bit_array_to_code . set_to_bit_array z  -- | The /prime/ form is the 'maximum' encoding. ----- > array_is_prime (set_to_array 12 [0,2,3,5]) == False-array_is_prime :: Array -> Bool-array_is_prime a =-    let c = array_to_code a-        p = array_to_set a+-- > bit_array_is_prime (set_to_bit_array 12 [0,2,3,5]) == False+bit_array_is_prime :: Bit_Array -> Bool+bit_array_is_prime a =+    let c = bit_array_to_code a+        p = bit_array_to_set a         n = length a-        z = flip mod n-        u = maximum (map (set_to_code n) (Z.z_sro_ti_related z p))+        z = Z.Z n+        u = maximum (map (set_to_code n) (SRO.z_sro_ti_related z p))     in c == u  -- | The augmentation rule adds @1@ in each empty slot at end of array. ----- > map array_pp (array_augment (parse_array "01000")) == ["01100","01010","01001"]-array_augment :: Array -> [Array]-array_augment a =+-- > map bit_array_pp (bit_array_augment (bit_array_parse "01000")) == ["01100","01010","01001"]+bit_array_augment :: Bit_Array -> [Bit_Array]+bit_array_augment a =     let (z,a') = break id (reverse a)         a'' = reverse a'         n = length z@@ -93,55 +108,61 @@     in map (a'' ++) x  -- | Enumerate first half of the set-classes under given /prime/ function.--- The second half can be derived as the complement of the first.+--   The second half can be derived as the complement of the first. ----- > import Music.Theory.Z12.Forte_1973+-- > import Music.Theory.Z.Forte_1973 -- > length scs == 224 -- > map (length . scs_n) [0..12] == [1,1,6,12,29,38,50,38,29,12,6,1,1] ----- > let z12 = map (fmap (map array_to_set)) (enumerate_half array_is_prime 12)+-- > let z12 = map (fmap (map bit_array_to_set)) (enumerate_half bit_array_is_prime 12) -- > map (length . snd) z12 == [1,1,6,12,29,38,50] -- -- This can become slow, edit /z/ to find out.  It doesn't matter -- about /n/.  This can be edited so that small /n/ would run quickly -- even for large /z/. ----- > fmap (map array_to_set) (lookup 5 (enumerate_half array_is_prime 16))-enumerate_half :: (Array -> Bool) -> Int -> [(Int,[Array])]+-- > fmap (map bit_array_to_set) (lookup 5 (enumerate_half bit_array_is_prime 16))+enumerate_half :: (Bit_Array -> Bool) -> Int -> [(Int,[Bit_Array])] enumerate_half pr n =     let a0 = replicate n False         f k a = if k >= n `div` 2                 then []-                else let r = filter pr (array_augment a)+                else let r = filter pr (bit_array_augment a)                      in (k + 1,r) : concatMap (f (k + 1)) r         jn l = case l of                  (x,y):l' -> (x,concat (y : map snd l'))                  _ -> error ""-        post_proc = map jn . T.group_on fst . sortOn fst+        post_proc = map jn . List.group_on fst . sortOn fst     in post_proc ((0,[a0]) : f 0 a0) --- * Alternate (reverse) form.+-- * LSB - LITTLE-ENDIAN +-- | If the size of the set is '>' 'code_len' then 'error', else 'id'.+set_coding_validate :: [t] -> [t]+set_coding_validate l = if length l <= code_len then l else error "set_coding_validate: SIZE"+ -- | Encoder for 'encode_prime'. ----- > encode [0,1,3,6,8,9] == 843-encode :: Integral i => [i] -> Code-encode = sum . map (2 ^)+-- > map set_encode [[0,1,3,7,8],[0,1,3,6,8,9]] == [395,843]+--+-- > map (set_to_code 12) [[0,1,3,7,8],[0,1,3,6,8,9]] == [3352,3372]+set_encode :: Integral i => [i] -> Code+set_encode = sum . map (2 ^) . set_coding_validate  -- | Decoder for 'encode_prime'. ----- > decode 12 843 == [0,1,3,6,8,9]-decode :: Integral i => i -> Code -> [i]-decode z n =-    let f i = (i,testBit n (fromIntegral i))+-- > map (set_decode 12) [395,843] == [[0,1,3,7,8],[0,1,3,6,8,9]]+set_decode :: Integral i => Int -> Code -> [i]+set_decode z n =+    let f i = (fromIntegral i,testBit n i)     in map fst (filter snd (map f [0 .. z - 1]))  -- | Binary encoding prime form algorithm, equalivalent to Rahn. ----- > encode_prime Z.mod12 [0,1,3,6,8,9] == [0,2,3,6,7,9]--- > Music.Theory.Z12.Rahn_1980.rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9]-encode_prime :: Integral i => Z.Z i -> [i] -> [i]-encode_prime z s =-    let t = map (\x -> Z.z_sro_tn z x s) (Z.z_univ z)-        c = t ++ map (Z.z_sro_invert z 0) t-    in decode (Z.z_modulus z) (minimum (map encode c))+-- > set_encode_prime Z.z12 [0,1,3,6,8,9] == [0,2,3,6,7,9]+-- > Music.Theory.Z.Rahn_1980.rahn_prime Z.z12 [0,1,3,6,8,9] == [0,2,3,6,7,9]+set_encode_prime :: Integral i => Z.Z i -> [i] -> [i]+set_encode_prime z s =+    let t = map (\x -> SRO.z_sro_tn z x s) (Z.z_univ z)+        c = t ++ map (SRO.z_sro_invert z 0) t+    in set_decode (fromIntegral (Z.z_modulus z)) (minimum (map set_encode c))
Music/Theory/Z/SRO.hs view
@@ -2,173 +2,198 @@ module Music.Theory.Z.SRO where  import Data.List {- base -}-import qualified Text.ParserCombinators.Parsec as P {- parsec -} -import qualified Music.Theory.List as T-import qualified Music.Theory.Parse as T+import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as P {- parsec -} +import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Parse as Parse {- hmt -}+ import Music.Theory.Z  -- | Serial operator,of the form rRTMI. data SRO t = SRO {sro_r :: Int                  ,sro_R :: Bool                  ,sro_T :: t-                 ,sro_M :: Bool+                 ,sro_M :: t -- 1 5                  ,sro_I :: Bool}              deriving (Eq,Show)  -- | Printer in 'rnRTnMI' form.-sro_pp :: Show t => SRO t -> String+sro_pp :: (Show t,Eq t,Num t) => SRO t -> String sro_pp (SRO rN r tN m i) =     concat [if rN /= 0 then 'r' : show rN else ""            ,if r then "R" else ""            ,'T' : show tN-           ,if m then "M" else ""+           ,if m == 5 then "M" else if m == 1 then "" else error "sro_pp: M?"            ,if i then "I" else ""] -p_sro :: Integral t => P.GenParser Char () (SRO t)-p_sro = do-  let rot = P.option 0 (P.char 'r' >> T.parse_int)+-- | Parser for SRO.+p_sro :: Integral t => t -> P.GenParser Char () (SRO t)+p_sro m_mul = do+  let rot = P.option 0 (P.char 'r' >> Parse.parse_int)   r <- rot-  r' <- T.is_char 'R'+  r' <- Parse.is_char 'R'   _ <- P.char 'T'-  t <- T.parse_int-  m <- T.is_char 'M'-  i <- T.is_char 'I'+  t <- Parse.parse_int+  m <- Parse.is_char 'M'+  i <- Parse.is_char 'I'   P.eof-  return (SRO r r' t m i)+  return (SRO r r' t (if m then m_mul else 1) i)  -- | Parse a Morris format serial operator descriptor. ----- > sro_parse "r2RT3MI" == SRO 2 True 3 True True-sro_parse :: Integral i => String -> SRO i-sro_parse =+-- > sro_parse 5 "r2RT3MI" == SRO 2 True 3 5 True+sro_parse :: Integral i => i -> String -> SRO i+sro_parse m =     either (\e -> error ("sro_parse failed\n" ++ show e)) id .-    P.parse p_sro ""+    P.parse (p_sro m) "" +-- * Z+ -- | The total set of serial operations. ----- > let u = z_sro_univ 3 mod12--- > zip (map sro_pp u) (map (\o -> z_sro_apply 5 mod12 o [0,1,3]) u)-z_sro_univ :: Integral i => Int -> Z i -> [SRO i]-z_sro_univ n_rot z =+-- > let u = z_sro_univ 3 5 z12+-- > zip (map sro_pp u) (map (\o -> z_sro_apply z12 o [0,1,3]) u)+z_sro_univ :: Integral i => Int -> i -> Z i -> [SRO i]+z_sro_univ n_rot m_mul z =     [SRO r r' t m i |      r <- [0 .. n_rot - 1],      r' <- [False,True],      t <- z_univ z,-     m <- [False,True],+     m <- [1,m_mul],      i <- [False,True]]  -- | The set of transposition 'SRO's. z_sro_Tn :: Integral i => Z i -> [SRO i]-z_sro_Tn z = [SRO 0 False n False False | n <- z_univ z]+z_sro_Tn z = [SRO 0 False n 1 False | n <- z_univ z]  -- | The set of transposition and inversion 'SRO's. z_sro_TnI :: Integral i => Z i -> [SRO i] z_sro_TnI z =-    [SRO 0 False n False i |+    [SRO 0 False n 1 i |      n <- z_univ z,      i <- [False,True]]  -- | The set of retrograde and transposition and inversion 'SRO's. z_sro_RTnI :: Integral i => Z i -> [SRO i] z_sro_RTnI z =-    [SRO 0 r n False i |+    [SRO 0 r n 1 i |      r <- [True,False],      n <- z_univ z,      i <- [False,True]] --- | The set of transposition, @M5@ and inversion 'SRO's.-z_sro_TnMI :: Integral i => Z i -> [SRO i]-z_sro_TnMI z =+-- | The set of transposition, @M@ and inversion 'SRO's.+z_sro_TnMI :: Integral i => i -> Z i -> [SRO i]+z_sro_TnMI m_mul z =     [SRO 0 False n m i |      n <- z_univ z,-     m <- [True,False],+     m <- [1,m_mul],      i <- [True,False]]  -- | The set of retrograde,transposition,@M5@ and inversion 'SRO's.-z_sro_RTnMI :: Integral i => Z i -> [SRO i]-z_sro_RTnMI z =+z_sro_RTnMI :: Integral i => i -> Z i -> [SRO i]+z_sro_RTnMI m_mul z =     [SRO 0 r n m i |      r <- [True,False],      n <- z_univ z,-     m <- [True,False],+     m <- [1,m_mul],      i <- [True,False]]  -- * Serial operations --- | Apply SRO.  M is ordinarily 5, but can be specified here.+-- | Apply SRO. ----- > z_sro_apply 5 mod12 (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4]--- > z_sro_apply 5 mod12 (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4]-z_sro_apply :: Integral i => i -> Z i -> SRO i -> [i] -> [i]-z_sro_apply mn z (SRO r r' t m i) x =+-- > z_sro_apply z12 (SRO 1 True 1 5 False) [0,1,2,3] == [11,6,1,4]+-- > z_sro_apply z12 (SRO 1 False 4 5 True) [0,1,2,3] == [11,6,1,4]+z_sro_apply :: Integral i => Z i -> SRO i -> [i] -> [i]+z_sro_apply z (SRO r r' t m i) x =     let x1 = if i then z_sro_invert z 0 x else x-        x2 = if m then z_sro_mn z mn x1 else x1+        x2 = if m == 1 then x1 else z_sro_mn z m x1         x3 = z_sro_tn z t x2         x4 = if r' then reverse x3 else x3-    in T.rotate_left r x4+    in List.rotate_left r x4 +-- * PLAIN+ -- | Transpose /p/ by /n/. ----- > z_sro_tn mod5 4 [0,1,4] == [4,0,3]--- > z_sro_tn mod12 4 [1,5,6] == [5,9,10]+-- > z_sro_tn z5 4 [0,1,4] == [4,0,3]+-- > z_sro_tn z12 4 [1,5,6] == [5,9,10] z_sro_tn :: (Integral i, Functor f) => Z i -> i -> f i -> f i z_sro_tn z n = fmap (z_add z n)  -- | Invert /p/ about /n/. ----- > z_sro_invert mod5 0 [0,1,4] == [0,4,1]--- > z_sro_invert mod12 6 [4,5,6] == [8,7,6]--- > z_sro_invert mod12 0 [0,1,3] == [0,11,9]+-- > z_sro_invert z5 0 [0,1,4] == [0,4,1]+-- > z_sro_invert z12 6 [4,5,6] == [8,7,6]+-- > map (z_sro_invert z12 0) [[0,1,3],[1,4,8]] == [[0,11,9],[11,8,4]] -- -- > import Data.Word {- base -}--- > z_sro_invert mod12 (0::Word8) [1,4,8]+-- > z_sro_invert z12 (0::Word8) [1,4,8] == [3,0,8] z_sro_invert :: (Integral i, Functor f) => Z i -> i -> f i -> f i z_sro_invert z n = fmap (\p -> z_sub z n (z_sub z p  n))  -- | Composition of 'invert' about @0@ and 'tn'. ----- > z_sro_tni mod5 1 [0,1,3] == [1,0,3]--- > z_sro_tni mod12 4 [1,5,6] == [3,11,10]--- > (z_sro_invert mod12 0 . z_sro_tn mod12 4) [1,5,6] == [7,3,2]+-- > z_sro_tni z5 1 [0,1,3] == [1,0,3]+-- > z_sro_tni z12 4 [1,5,6] == [3,11,10]+-- > (z_sro_invert z12 0 . z_sro_tn z12 4) [1,5,6] == [7,3,2] z_sro_tni :: (Integral i, Functor f) => Z i -> i -> f i -> f i z_sro_tni z n = z_sro_tn z n . z_sro_invert z 0  -- | Modulo multiplication. ----- > z_sro_mn mod12 11 [0,1,4,9] == z_tni mod12 0 [0,1,4,9]+-- > z_sro_mn z12 11 [0,1,4,9] == z_sro_tni z12 0 [0,1,4,9] z_sro_mn :: (Integral i, Functor f) => Z i -> i -> f i -> f i z_sro_mn z n = fmap (z_mul z n) +-- | M5, ie. 'mn' @5@.+--+-- > z_sro_m5 z12 [0,1,3] == [0,5,3]+z_sro_m5 :: (Integral i, Functor f) => Z i -> f i -> f i+z_sro_m5 z = z_sro_mn z 5+ -- | T-related sequences of /p/. ----- > length (z_sro_t_related mod12 [0,3,6,9]) == 12--- > z_sro_t_related mod5 [0,2] == [[0,2],[1,3],[2,4],[3,0],[4,1]]+-- > length (z_sro_t_related z12 [0,3,6,9]) == 12+-- > z_sro_t_related z5 [0,2] == [[0,2],[1,3],[2,4],[3,0],[4,1]] z_sro_t_related :: (Integral i, Functor f) => Z i -> f i -> [f i] z_sro_t_related z p = fmap (\n -> z_sro_tn z n p) (z_univ z)  -- | T\/I-related sequences of /p/. ----- > length (z_sro_ti_related mod12 [0,1,3]) == 24--- > length (z_sro_ti_related mod12 [0,3,6,9]) == 24--- > z_sro_ti_related mod12 [0] == map return [0..11]+-- > length (z_sro_ti_related z12 [0,1,3]) == 24+-- > length (z_sro_ti_related z12 [0,3,6,9]) == 24+-- > z_sro_ti_related z12 [0] == map return [0..11] z_sro_ti_related :: (Eq (f i), Integral i, Functor f) => Z i -> f i -> [f i] z_sro_ti_related z p = nub (z_sro_t_related z p ++ z_sro_t_related z (z_sro_invert z 0 p))  -- | R\/T\/I-related sequences of /p/. ----- > length (z_sro_rti_related mod12 [0,1,3]) == 48--- > length (z_sro_rti_related mod12 [0,3,6,9]) == 24+-- > length (z_sro_rti_related z12 [0,1,3]) == 48+-- > length (z_sro_rti_related z12 [0,3,6,9]) == 24 z_sro_rti_related :: Integral i => Z i -> [i] -> [[i]] z_sro_rti_related z p = let q = z_sro_ti_related z p in nub (q ++ map reverse q) +-- | T\/M\/I-related sequences of /p/, duplicates removed.+z_sro_tmi_related :: Integral i => Z i -> [i] -> [[i]]+z_sro_tmi_related z p = let q = z_sro_ti_related z p in nub (q ++ map (z_sro_m5 z) q)++-- | R\/T\/M\/I-related sequences of /p/, duplicates removed.+z_sro_rtmi_related :: Integral i => Z i -> [i] -> [[i]]+z_sro_rtmi_related z p = let q = z_sro_tmi_related z p in nub (q ++ map reverse q)++-- | r\/R\/T\/M\/I-related sequences of /p/, duplicates removed.+z_sro_rrtmi_related :: Integral i => Z i -> [i] -> [[i]]+z_sro_rrtmi_related z p = nub (concatMap (z_sro_rtmi_related z) (List.rotations p))+ -- * Sequence operations  -- | Variant of 'tn', transpose /p/ so first element is /n/. ----- > z_sro_tn_to mod12 5 [0,1,3] == [5,6,8]--- > map (z_sro_tn_to mod12 0) [[0,1,3],[1,3,0],[3,0,1]]+-- > z_sro_tn_to z12 5 [0,1,3] == [5,6,8]+-- > map (z_sro_tn_to z12 0) [[0,1,3],[1,3,0],[3,0,1]] == [[0,1,3],[0,2,11],[0,9,10]] z_sro_tn_to :: Integral i => Z i -> i -> [i] -> [i] z_sro_tn_to z n p =     case p of@@ -177,13 +202,13 @@  -- | Variant of 'invert', inverse about /n/th element. ----- > map (z_sro_invert_ix mod12 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]]--- > map (z_sro_invert_ix mod12 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]]+-- > map (z_sro_invert_ix z12 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]]+-- > map (z_sro_invert_ix z12 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] z_sro_invert_ix :: Integral i => Z i -> Int -> [i] -> [i] z_sro_invert_ix z n p = z_sro_invert z (p !! n) p  -- | The standard t-matrix of /p/. ----- > z_tmatrix mod12 [0,1,3] == [[0,1,3],[11,0,2],[9,10,0]]+-- > z_tmatrix z12 [0,1,3] == [[0,1,3],[11,0,2],[9,10,0]] z_tmatrix :: Integral i => Z i -> [i] -> [[i]] z_tmatrix z p = map (\n -> z_sro_tn z n p) (z_sro_tn_to z 0 (z_sro_invert_ix z 0 p))
Music/Theory/Z/TTO.hs view
@@ -1,75 +1,148 @@+-- | Generalised twelve-tone operations on un-ordered pitch-class sets with arbitrary Z. module Music.Theory.Z.TTO where  import Data.List {- base -} import Data.Maybe {- base -}-import qualified Text.ParserCombinators.Parsec as P {- parsec -} -import qualified Music.Theory.Parse as T-import qualified Music.Theory.Set.List as T-import Music.Theory.Z+import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as P {- parsec -} +import qualified Music.Theory.Parse as Parse {- hmt -}++import Music.Theory.Z {- hmt -}++-- * TTO+ -- | Twelve-tone operator, of the form TMI.-data TTO t = TTO {tto_T :: t,tto_M :: Bool,tto_I :: Bool}+data TTO t = TTO {tto_T :: t,tto_M :: t,tto_I :: Bool}              deriving (Eq,Show) +-- | T0 tto_identity :: Num t => TTO t-tto_identity = TTO 0 False False+tto_identity = TTO 0 1 False --- | Pretty printer.-tto_pp :: Show t => TTO t -> String-tto_pp (TTO t m i) = concat ['T' : show t,if m then "M" else "",if i then "I" else ""]+-- | Pretty printer.  It is an error here is M is not 1 or 5.+tto_pp :: (Show t,Num t,Eq t) => TTO t -> String+tto_pp (TTO t m i) =+  concat ['T' : show t+         ,if m == 1 then "" else if m == 5 then "M" else error "tto_pp: M?"+         ,if i then "I" else ""] -p_tto :: Integral t => P.GenParser Char () (TTO t)-p_tto = do+-- | Parser for TTO, requires value for M (ordinarily 5 for 12-tone TTO).+p_tto :: Integral t => t -> P.GenParser Char () (TTO t)+p_tto m_mul = do   _ <- P.char 'T'-  t <- T.parse_int-  m <- T.is_char 'M'-  i <- T.is_char 'I'+  t <- Parse.parse_int+  m <- Parse.is_char 'M'+  i <- Parse.is_char 'I'   P.eof-  return (TTO t m i)+  return (TTO t (if m then m_mul else 1) i)  -- | Parser, transposition must be decimal. ----- > map (tto_pp . tto_parse) (words "T5 T3I T11M T9MI")-tto_parse :: Integral i => String -> TTO i-tto_parse = either (\e -> error ("tto_parse failed\n" ++ show e)) id . P.parse p_tto ""+-- > map (tto_pp . tto_parse 5) (words "T5 T3I T11M T9MI") == ["T5","T3I","T11M","T9MI"]+tto_parse :: Integral i => i -> String -> TTO i+tto_parse m = either (\e -> error ("tto_parse failed\n" ++ show e)) id . P.parse (p_tto m) "" --- | The set of all 'TTO', given 'Z' function.+-- | Set M at TTO.+tto_M_set :: Integral t => t -> TTO t -> TTO t+tto_M_set m (TTO t _ i) = TTO t m i++-- * Z++-- | The set of all 'TTO', given 'Z'. ----- > length (z_tto_univ mod12) == 48--- > map tto_pp (z_tto_univ mod12)-z_tto_univ :: Integral t => Z t -> [TTO t]-z_tto_univ z = [TTO t m i | m <- [False,True], i <- [False,True], t <- z_univ z]+-- > length (z_tto_univ 5 z12) == 48+-- > map tto_pp (z_tto_univ 5 z12)+z_tto_univ :: Integral t => t -> Z t -> [TTO t]+z_tto_univ m_mul z = [TTO t m i | m <- [1,m_mul], i <- [False,True], t <- z_univ z] --- | M is ordinarily 5, but can be specified here.+-- | Apply TTO to pitch-class. ----- > map (z_tto_f 5 mod12 (tto_parse "T1M")) [0,1,2,3] == [1,6,11,4]-z_tto_f :: Integral t => t -> Z t -> TTO t -> (t -> t)-z_tto_f mn z (TTO t m i) =+-- > map (z_tto_f z12 (tto_parse 5 "T1M")) [0,1,2,3] == [1,6,11,4]+z_tto_f :: Integral t => Z t -> TTO t -> (t -> t)+z_tto_f z (TTO t m i) =     let i_f = if i then z_negate z else id-        m_f = if m then z_mul z mn else id+        m_f = if m == 1 then id else z_mul z m         t_f = if t > 0 then z_add z t else id     in t_f . m_f . i_f --- | 'sort' of 'map' 'z_tto_f'.+-- | 'nub' of 'sort' of 'z_tto_f'.  (nub because M may be 0). ----- > z_tto_apply 5 mod12 (tto_parse "T1M") [0,1,2,3] == [1,4,6,11]-z_tto_apply :: Integral t => t -> Z t -> TTO t -> [t] -> [t]-z_tto_apply mn z o = sort . map (z_tto_f mn z o)--tto_apply :: Integral t => t -> TTO t -> [t] -> [t]-tto_apply mn = z_tto_apply mn id+-- > z_tto_apply z12 (tto_parse 5 "T1M") [0,1,2,3] == [1,4,6,11]+z_tto_apply :: Integral t => Z t -> TTO t -> [t] -> [t]+z_tto_apply z o = nub . sort . map (z_tto_f z o) --- | Find 'TTO' that that map /x/ to /y/ given /m/ and /z/.+-- | Find 'TTO's that map pc-set /x/ to pc-set /y/ given /m/ and /z/. ----- > map tto_pp (z_tto_rel 5 mod12 [0,1,2,3] [6,4,1,11]) == ["T1M","T4MI"]+-- > map tto_pp (z_tto_rel 5 z12 [0,1,2,3] [1,4,6,11]) == ["T1M","T4MI"] z_tto_rel :: (Ord t,Integral t) => t -> Z t -> [t] -> [t] -> [TTO t] z_tto_rel m z x y =-    let q = T.set y-    in mapMaybe (\o -> if z_tto_apply m z o x == q then Just o else Nothing) (z_tto_univ z)+  let f o = if z_tto_apply z o x == y then Just o else Nothing+  in mapMaybe f (z_tto_univ m z) --- | 'nub' of 'sort' of 'map' /z/.+-- * PLAIN++-- | 'nub' of 'sort' of 'z_mod' of /z/. ----- > map (z_pcset mod12) [[0,6],[6,12],[12,18]] == replicate 3 [0,6]-z_pcset :: Ord t => Z t -> [t] -> [t]-z_pcset z = nub . sort . map z+-- > z_pcset z12 [1,13] == [1]+-- > map (z_pcset z12) [[0,6],[6,12],[12,18]] == replicate 3 [0,6]+z_pcset :: (Integral t,Ord t) => Z t -> [t] -> [t]+z_pcset z = nub . sort . map (z_mod z)++-- | Transpose by n.+--+-- > z_tto_tn z12 4 [1,5,6] == [5,9,10]+-- > z_tto_tn z12 4 [0,4,8] == [0,4,8]+z_tto_tn :: Integral i => Z i -> i -> [i] -> [i]+z_tto_tn z n = sort . map (z_add z n)++-- | Invert about n.+--+-- > z_tto_invert z12 6 [4,5,6] == [6,7,8]+-- > z_tto_invert z12 0 [0,1,3] == [0,9,11]+z_tto_invert :: Integral i => Z i -> i -> [i] -> [i]+z_tto_invert z n = sort . map (\p -> z_sub z n (z_sub z p n))++-- | Composition of 'z_tto_invert' about @0@ and 'z_tto_tn'.+--+-- > z_tto_tni z12 4 [1,5,6] == [3,10,11]+-- > (z_tto_invert z12 0 . z_tto_tn z12 4) [1,5,6] == [2,3,7]+z_tto_tni :: Integral i => Z i -> i -> [i] -> [i]+z_tto_tni z n = z_tto_tn z n . z_tto_invert z 0++-- | Modulo-z multiplication+--+-- > z_tto_mn z12 11 [0,1,4,9] == z_tto_invert z12 0 [0,1,4,9]+z_tto_mn :: Integral i => Z i -> i -> [i] -> [i]+z_tto_mn z n = sort . map (z_mul z n)++-- | M5, ie. 'mn' @5@.+--+-- > z_tto_m5 z12 [0,1,3] == [0,3,5]+z_tto_m5 :: Integral i => Z i -> [i] -> [i]+z_tto_m5 z = z_tto_mn z 5++-- * SEQUENCE++-- | T-related sets of /p/.+z_tto_t_related_seq :: Integral i => Z i -> [i] -> [[i]]+z_tto_t_related_seq z p = map (\q -> z_tto_tn z q p) [0..11]++-- | Unique elements of 'z_tto_t_related_seq'.+--+-- > length (z_tto_t_related z12 [0,1,3]) == 12+-- > z_tto_t_related z12 [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]+z_tto_t_related :: Integral i => Z i -> [i] -> [[i]]+z_tto_t_related z = nub . z_tto_t_related_seq z++-- | T\/I-related set of /p/.+z_tto_ti_related_seq :: Integral i => Z i -> [i] -> [[i]]+z_tto_ti_related_seq z p = z_tto_t_related z p ++ z_tto_t_related z (z_tto_invert z 0 p)++-- | Unique elements of 'z_tto_ti_related_seq'.+--+-- > length (z_tto_ti_related z12 [0,1,3]) == 24+-- > z_tto_ti_related z12 [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]+z_tto_ti_related :: Integral i => Z i -> [i] -> [[i]]+z_tto_ti_related z = nub . z_tto_ti_related_seq z
− Music/Theory/Z12.hs 
@@ -1,111 +0,0 @@-{-# Language DataKinds #-}-{- | Z12--Z12 are modulo 12 integers.--> map signum [-1,0::Z12,1] == [1,0,1]-> map abs [-1,0::Z12,1] == [11,0,1]--Aspects of the 'Enum' instance are cyclic.--> pred (0::Z12) == 11-> succ (11::Z12) == 0--'Bounded' works--> [minBound::Z12 .. maxBound] == [0::Z12 .. 11]---}-module Music.Theory.Z12 where--import Data.Char {- base -}-import Data.List {- base -}-import qualified Data.Modular as M {- modular-arithmetic -}-import qualified GHC.TypeLits as L {- base -}--import qualified Music.Theory.List as T {- hmt -}---- | 'Mod' 'Int'.-type Z n = M.Mod Int n---- | 'Z' 12.------ > map negate [0::Z12 .. 0xB] == [0,0xB,0xA,9,8,7,6,5,4,3,2,1]--- > map (+ 5) [0::Z12 .. 11] == [5,6,7,8,9,0xA,0xB,0,1,2,3,4]-type Z12 = M.Mod Int 12---- | Cyclic form of 'enumFromThenTo'.------ > [9::Z12,11 .. 3] == []--- > enumFromThenTo_cyc (9::Z12) 11 3 == [9,11,1,3]-enumFromThenTo_cyc :: L.KnownNat n => Z n -> Z n -> Z n -> [Z n]-enumFromThenTo_cyc n m o =-    let m' = m + (m - n)-    in case compare m' o of-         LT -> n : enumFromThenTo_cyc m m' o-         EQ -> [n,m,o]-         GT -> [n,m]---- | Cyclic form of 'enumFromTo'.------ > [9::Z12 .. 3] == []--- > enumFromTo_cyc (9::Z12) 3 == [9,10,11,0,1,2,3]-enumFromTo_cyc :: L.KnownNat n => Z n -> Z n -> [Z n]-enumFromTo_cyc n m =-    let n' = succ n-    in if n' == m then [n,m] else n : enumFromTo_cyc n' m--{---}---- | Convert integral to 'Z12'.------ > map to_Z12 [-9,-3,0,13] == [3,9,0,1]-to_Z12 :: Integral i => i -> Z12-to_Z12 = M.toMod . fromIntegral--int_to_Z12 :: Int -> Z12-int_to_Z12 = to_Z12---- | Convert 'Z12' to integral.-from_Z12 :: Integral i => Z12 -> i-from_Z12 = fromIntegral . M.unMod--int_from_Z12 :: Z12 -> Int-int_from_Z12 = from_Z12---- | Z12 not in set.------ > complement [0,2,4,5,7,9,11] == [1,3,6,8,10]-complement :: [Z12] -> [Z12]-complement = (\\) [0 .. 11]---- | Z12 to character (10 -> A, 11 -> B).------ > map z12_to_char [0 .. 11] == "0123456789AB"-z12_to_char :: Z12 -> Char-z12_to_char = toUpper . intToDigit . M.unMod---- | Z12 to character (10 -> A, 11 -> B).------ > map char_to_z12 "0123456789AB" == [0..11]-char_to_z12 :: Char -> Z12-char_to_z12 = to_Z12 . digitToInt---- | Unordered set notation (braces).------ > z12_set_pp [0,1,3] == "{013}"-z12_set_pp :: [Z12] -> String-z12_set_pp = T.bracket ('{','}') . map z12_to_char---- | Ordered sequence notation (angle brackets).------ > z12_seq_pp [0,1,3] == "<013>"-z12_seq_pp :: [Z12] -> String-z12_seq_pp = T.bracket ('<','>') . map z12_to_char---- | Ordered vector notation (square brackets).------ > z12_vec_pp [0,1,3] == "[013]"-z12_vec_pp :: [Z12] -> String-z12_vec_pp = T.bracket ('[',']') . map z12_to_char
− Music/Theory/Z12/Castren_1994.hs 
@@ -1,151 +0,0 @@--- | Marcus Castrén. /RECREL: A Similarity Measure for Set-Classes/. PhD--- thesis, Sibelius Academy, Helsinki, 1994.-module Music.Theory.Z12.Castren_1994 where--import Data.List {- base -}-import Data.Maybe {- base -}-import Data.Ratio {- base -}--import qualified Music.Theory.List as T-import Music.Theory.Z (mod12)-import qualified Music.Theory.Z.SRO as T-import qualified Music.Theory.Z.Forte_1973 as T--type Z12 = Int---- | Is /p/ symmetrical under inversion.------ > map inv_sym (T.scs_n 2) == [True,True,True,True,True,True]--- > map (fromEnum.inv_sym) (T.scs_n 3) == [1,0,0,0,0,1,0,0,1,1,0,1]-inv_sym :: [Z12] -> Bool-inv_sym x = x `elem` map (\i -> sort (T.z_sro_tn mod12 i (T.z_sro_invert mod12 0 x))) [0..11]---- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'.------ > sc_t_ti [0,2,4] == Nothing--- > sc_t_ti [0,1,3] == Just ([0,1,3],[0,2,3])-sc_t_ti :: [Z12] -> Maybe ([Z12], [Z12])-sc_t_ti p =-    if inv_sym p-    then Nothing-    else Just (p,T.t_prime mod12 (T.z_sro_invert mod12 0 p))---- | Transpositional equivalence variant of Forte's 'sc_table'.  The--- inversionally related classes are distinguished by labels @A@ and--- @B@; the class providing the /best normal order/ (Forte 1973) is--- always the @A@ class. If neither @A@ nor @B@ appears in the name of--- a set-class, it is inversionally symmetrical.------ > (length T.sc_table,length t_sc_table) == (224,352)--- > lookup "5-Z18B" t_sc_table == Just [0,2,3,6,7]-t_sc_table :: [(T.SC_Name,[Z12])]-t_sc_table =-    let f x = let nm = T.sc_name mod12 x-              in case sc_t_ti x of-                   Nothing -> [(nm,x)]-                   Just (p,q) -> [(nm++"A",p),(nm++"B",q)]-    in concatMap f T.scs---- | Lookup a set-class name.  The input set is subject to--- 't_prime' before lookup.------ > t_sc_name [0,2,3,6,7] == "5-Z18B"--- > t_sc_name [0,1,4,6,7,8] == "6-Z17B"-t_sc_name :: [Z12] -> T.SC_Name-t_sc_name p =-    let n = find (\(_,q) -> T.t_prime mod12 p == q) t_sc_table-    in fst (fromJust n)---- | Lookup a set-class given a set-class name.------ > t_sc "6-Z17A" == [0,1,2,4,7,8]-t_sc :: T.SC_Name -> [Z12]-t_sc n = snd (fromJust (find (\(m,_) -> n == m) t_sc_table))---- | List of set classes.-t_scs :: [[Z12]]-t_scs = map snd t_sc_table---- | Cardinality /n/ subset of 't_scs'.------ > map (length . t_scs_n) [2..10] == [6,19,43,66,80,66,43,19,6]-t_scs_n :: Integral i => i -> [[Z12]]-t_scs_n n = filter ((== n) . genericLength) t_scs---- | T-related /q/ that are subsets of /p/.------ > t_subsets [0,1,2,3,4] [0,1]  == [[0,1],[1,2],[2,3],[3,4]]--- > t_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4]]--- > t_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6]]-t_subsets :: [Z12] -> [Z12] -> [[Z12]]-t_subsets x a = filter (`T.is_subset` x) (map sort (T.z_sro_t_related mod12 a))---- | T\/I-related /q/ that are subsets of /p/.------ > ti_subsets [0,1,2,3,4] [0,1]  == [[0,1],[1,2],[2,3],[3,4]]--- > ti_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4],[0,3,4]]--- > ti_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6],[3,6,7]]-ti_subsets :: [Z12] -> [Z12] -> [[Z12]]-ti_subsets x a = filter (`T.is_subset` x) (nub (map sort (T.z_sro_ti_related mod12 a)))---- | Trivial run length encoder.------ > rle "abbcccdde" == [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')]-rle :: (Eq a,Integral i) => [a] -> [(i,a)]-rle =-    let f x = (genericLength x,head x)-    in map f . group---- | Inverse of 'rle'.------ > rle_decode [(5,'a'),(4,'b')] == "aaaaabbbb"-rle_decode :: (Integral i) => [(i,a)] -> [a]-rle_decode =-    let f (i,j) = genericReplicate i j-    in concatMap f---- | Length of /rle/ encoded sequence.------ > rle_length [(5,'a'),(4,'b')] == 9-rle_length :: (Integral i) => [(i,a)] -> i-rle_length = sum . map fst---- | T-equivalence /n/-class vector (subset-class vector, nCV).------ > t_n_class_vector 2 [0..4] == [4,3,2,1,0,0]--- > rle (t_n_class_vector 3 [0..4]) == [(1,3),(2,2),(2,1),(4,0),(1,1),(9,0)]--- > rle (t_n_class_vector 4 [0..4]) == [(1,2),(3,1),(39,0)]-t_n_class_vector :: (Num a, Integral i) => i -> [Z12] -> [a]-t_n_class_vector n x =-    let a = t_scs_n n-    in map (genericLength . t_subsets x) a---- | T\/I-equivalence /n/-class vector (subset-class vector, nCV).------ > ti_n_class_vector 2 [0..4] == [4,3,2,1,0,0]--- > ti_n_class_vector 3 [0,1,2,3,4] == [3,4,2,0,0,1,0,0,0,0,0,0]--- > rle (ti_n_class_vector 4 [0,1,2,3,4]) == [(2,2),(1,1),(26,0)]-ti_n_class_vector :: (Num b, Integral i) => i -> [Z12] -> [b]-ti_n_class_vector n x =-    let a = T.scs_n n-    in map (genericLength . ti_subsets x) a---- | 'icv' scaled by sum of /icv/.------ > dyad_class_percentage_vector [0,1,2,3,4] == [40,30,20,10,0,0]--- > dyad_class_percentage_vector [0,1,4,5,7] == [20,10,20,20,20,10]-dyad_class_percentage_vector :: Integral i => [Z12] -> [i]-dyad_class_percentage_vector p =-    let p' = T.icv 12 p-    in map (sum p' *) p'---- | /rel/ metric.------ > rel [0,1,2,3,4] [0,1,4,5,7] == 40--- > rel [0,1,2,3,4] [0,2,4,6,8] == 60--- > rel [0,1,4,5,7] [0,2,4,6,8] == 60-rel :: Integral i => [Z12] -> [Z12] -> Ratio i-rel x y =-    let x' = dyad_class_percentage_vector x-        y' = dyad_class_percentage_vector y-    in sum (map abs (zipWith (-) x' y')) % 2
− Music/Theory/Z12/Drape_1999.hs 
@@ -1,588 +0,0 @@--- | Haskell implementations of @pct@ operations.--- See <http://slavepianos.org/rd/t/pct>.-module Music.Theory.Z12.Drape_1999 where--import Data.Function {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}-import Safe {- safe -}--import qualified Music.Theory.List as T-import qualified Music.Theory.Set.List as T-import qualified Music.Theory.Tuple as T--import qualified Music.Theory.Z as Z-import qualified Music.Theory.Z.SRO as Z-import qualified Music.Theory.Z.TTO as Z--import Music.Theory.Z12 (Z12)-import qualified Music.Theory.Z12 as Z12-import qualified Music.Theory.Z12.Forte_1973 as Z12-import qualified Music.Theory.Z12.TTO as Z12-import qualified Music.Theory.Z12.SRO as Z12---- | Cardinality filter------ > cf [0,3] (cg [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]]-cf :: (Integral n) => [n] -> [[a]] -> [[a]]-cf ns = filter (\p -> genericLength p `elem` ns)---- | Combinatorial sets formed by considering each set as possible--- values for slot.------ > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]]--- > let n = "01" in cgg [n,n,n] == ["000","001","010","011","100","101","110","111"]-cgg :: [[a]] -> [[a]]-cgg l =-    case l of-      x:xs -> [ y:z | y <- x, z <- cgg xs ]-      _ -> [[]]---- | Combinations generator, ie. synonym for 'T.powerset'.------ > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]]-cg :: [a] -> [[a]]-cg = T.powerset---- | Powerset filtered by cardinality.------ >>> pct cg -r3 0159--- 015--- 019--- 059--- 159------ > cg_r 3 [0,1,5,9] == [[0,1,5],[0,1,9],[0,5,9],[1,5,9]]-cg_r :: (Integral n) => n -> [a] -> [[a]]-cg_r n = cf [n] . cg--{- | Chain pcsegs.-->>> echo 024579 | pct chn T0 3 | sort -u-579468 (RT8M)-579A02 (T5)--> chn_t0 3 [0,2,4,5,7,9] == [[5,7,9,10,0,2],[5,7,9,4,6,8]]-->>> echo 02457t | pct chn T0 2-7A0135 (RT5I)-7A81B9 (RT9MI)--> chn_t0 2 [0,2,4,5,7,10] == [[7,10,0,1,3,5],[7,10,8,1,11,9]]---}-chn_t0 :: Int -> [Z12] -> [[Z12]]-chn_t0 n p =-    let f q = T.take_right n p == take n q-    in filter f (Z12.sro_rtmi_related p)--{- | Cyclic interval segment.-->>> echo 014295e38t76 | pct cisg-13A7864529B6--> ciseg [0,1,4,2,9,5,11,3,8,10,7,6] == [1,3,10,7,8,6,4,5,2,9,11,6]---}-ciseg :: [Z12] -> [Z12]-ciseg = T.d_dx . cyc---- | Synonynm for 'complement'.------ >>> pct cmpl 02468t--- 13579B------ > cmpl [0,2,4,6,8,10] == [1,3,5,7,9,11]-cmpl :: [Z12] -> [Z12]-cmpl = Z12.complement---- | Form cycle.------ >>> echo 056 | pct cyc--- 0560------ > cyc [0,5,6] == [0,5,6,0]-cyc :: [a] -> [a]-cyc l =-    case l of-      [] -> []-      x:xs -> (x:xs) ++ [x]---- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor--- set, 'o' for octotonic set.-d_nm :: (Integral a) => [a] -> Maybe Char-d_nm x =-    case x of-      [0,2,4,5,7,9,11] -> Just 'd'-      [0,2,3,5,7,9,11] -> Just 'm'-      [0,1,3,4,6,7,9,10] -> Just 'o'-      _ -> Nothing---- | Diatonic implications.-dim :: [Z12] -> [(Z12,[Z12])]-dim p =-    let g (i,q) = T.is_subset p (Z12.tto_tn i q)-        f = filter g . zip [0..11] . repeat-        d = [0,2,4,5,7,9,11]-        m = [0,2,3,5,7,9,11]-        o = [0,1,3,4,6,7,9,10]-    in f d ++ f m ++ f o---- | Variant of 'dim' that is closer to the 'pct' form.------ >>> pct dim 016--- T1d--- T1m--- T0o------ > dim_nm [0,1,6] == [(1,'d'),(1,'m'),(0,'o')]-dim_nm :: [Z12] -> [(Z12,Char)]-dim_nm =-    let pk f (i,j) = (i,f j)-    in nubBy ((==) `on` snd) .-       map (pk (fromMaybe (error "dim_mn") . d_nm)) .-       dim---- | Diatonic interval set to interval set.------ >>> pct dis 24--- 1256------ > dis [2,4] == [1,2,5,6]-dis :: (Integral t) => [Int] -> [t]-dis =-    let is = [[], [], [1,2], [3,4], [5,6], [6,7], [8,9], [10,11]]-    in concatMap (\j -> is !! j)---- | Degree of intersection.------ >>> echo 024579e | pct doi 6 | sort -u--- 024579A--- 024679B------ > let p = [0,2,4,5,7,9,11]--- > in doi 6 p p == [[0,2,4,5,7,9,10],[0,2,4,6,7,9,11]]------ >>> echo 01234 | pct doi 2 7-35 | sort -u--- 13568AB------ > doi 2 (T.sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]]-doi :: Int -> [Z12] -> [Z12] -> [[Z12]]-doi n p q =-    let f j = [Z12.tto_tn j p,Z12.tto_tni j p]-        xs = concatMap f [0..11]-    in T.set (filter (\x -> length (x `intersect` q) == n) xs)---- | Forte name.-fn :: [Z12] -> String-fn = Z12.sc_name---- | Z12 cycles.-frg_cyc :: T.T6 [[Z12]]-frg_cyc =-    let c1 = [[0..11]]-        c2 = map (\n -> map (+ n) [0,2..10]) [0..1]-        c3 = map (\n -> map (+ n) [0,3..9]) [0..2]-        c4 = map (\n -> map (+ n) [0,4..8]) [0..3]-        c5 = map (map (* 5)) c1-        c6 = map (\n -> map (+ n) [0,6]) [0..5]-    in (c1,c2,c3,c4,c5,c6)---- | Fragmentation of cycles.-frg :: [Z12] -> T.T6 [String]-frg p =-    let f = map (\n -> if n `elem` p then Z12.z12_to_char n else '-')-    in T.t6_map (map f) frg_cyc--ic_cycle_vector :: [Z12] -> T.T6 [Int]-ic_cycle_vector p =-    let f str = let str' = if length str > 2 then T.close str else str-                in length (filter (\(x,y) -> x /= '-' && y /= '-') (T.adj2 1 str'))-    in T.t6_map (map f) (frg p)---- | Pretty printer for 'ic_cycle_vector'.------ > let r = "IC cycle vector: <1> <22> <111> <1100> <5> <000000>"--- > in ic_cycle_vector_pp (ic_cycle_vector [0,2,4,5,7,9]) == r-ic_cycle_vector_pp :: T.T6 [Int] -> String-ic_cycle_vector_pp = ("IC cycle vector: " ++) . unwords . T.t6_to_list . T.t6_map Z.z16_seq_pp--frg_hdr :: [String]-frg_hdr = map (\n -> "Fragmentation of " ++ show n ++ "-cycle(s)") [1::Int .. 6]--{-| Fragmentation of cycles.-->>> pct frg 024579-Fragmentation of 1-cycle(s):  [0-2-45-7-9--]-Fragmentation of 2-cycle(s):  [024---] [--579-]-Fragmentation of 3-cycle(s):  [0--9] [-47-] [25--]-Fragmentation of 4-cycle(s):  [04-] [-59] [2--] [-7-]-Fragmentation of 5-cycle(s):  [05------4927]-Fragmentation of 6-cycle(s):  [0-] [-7] [2-] [-9] [4-] [5-]-IC cycle vector: <1> <22> <111> <1100> <5> <000000>--> putStrLn $ frg_pp [0,2,4,5,7,9]--}-frg_pp :: [Z12] -> String-frg_pp =-    let f = unwords . map (\p -> T.bracket ('[',']') p)-        g x y = x ++ ": " ++ y-    in unlines . zipWith g frg_hdr . T.t6_to_list . T.t6_map f . frg---- | Embedded segment search.------ >>> echo 23A | pct ess 0164325--- 2B013A9--- 923507A------ > ess [0,1,6,4,3,2,5] [2,3,10] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]]-ess :: [Z12] -> [Z12] -> [[Z12]]-ess p q = filter (`T.is_embedding` q) (Z12.sro_rtmi_related p)---- | Can the set-class q (under prime form algorithm pf) be---   drawn from the pcset p.-has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool-has_sc_pf pf p q =-    let n = length q-    in pf q `elem` map pf (cf [n] (cg p))---- | Can the set-class q be drawn from the pcset p.------ > let d = [0,2,4,5,7,9,11] in has_sc d (complement d) == True--- > has_sc [] [] == True-has_sc :: [Z12] -> [Z12] -> Bool-has_sc = has_sc_pf Z12.forte_prime---- | Interval cycle filter.------ >>> echo 22341 | pct icf--- 22341------ > icf [[2,2,3,4,1]] == [[2,2,3,4,1]]-icf :: (Num a,Eq a) => [[a]] -> [[a]]-icf = filter ((== 12) . sum)---- | Interval class set to interval sets.------ >>> pct ici -c 123--- 123--- 129--- 1A3--- 1A9------ > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]-ici :: (Num t) => [Int] -> [[t]]-ici xs =-    let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j-        ys = map is xs-    in cgg ys---- | Interval class set to interval sets, concise variant.------ > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]]-ici_c :: [Int] -> [[Int]]-ici_c [] = []-ici_c (x:xs) = map (x:) (ici xs)---- | Interval-class segment.------ >>> pct icseg 013265e497t8--- 12141655232------ > icseg [0,1,3,2,6,5,11,4,9,7,10,8] == [1,2,1,4,1,6,5,5,2,3,2]-icseg :: [Z12] -> [Z12]-icseg = map Z12.ic . iseg---- | Interval segment (INT).-iseg :: [Z12] -> [Z12]-iseg = T.d_dx---- | Imbrications.------ > let r = [[[0,2,4],[2,4,5],[4,5,7],[5,7,9]]--- >         ,[[0,2,4,5],[2,4,5,7],[4,5,7,9]]]--- > in imb [3,4] [0,2,4,5,7,9] == r-imb :: (Integral n) => [n] -> [a] -> [[[a]]]-imb cs p =-    let g n = (== n) . genericLength-        f ps n = filter (g n) (map (genericTake n) ps)-    in map (f (tails p)) cs--{- | 'issb' gives the set-classes that can append to 'p' to give 'q'.-->>> pct issb 3-7 6-32-3-7-3-2-3-11--> issb (T.sc "3-7") (T.sc "6-32") == ["3-2","3-7","3-11"]---}-issb :: [Z12] -> [Z12] -> [String]-issb p q =-    let k = length q - length p-        f = any id . map (\x -> Z12.forte_prime (p ++ x) == q) . Z12.tto_ti_related-    in map Z12.sc_name (filter f (cf [k] Z12.scs))---- | Matrix search.------ >>> pct mxs 024579 642 | sort -u--- 6421B9--- B97642------ > T.set (mxs [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]]-mxs :: [Z12] -> [Z12] -> [[Z12]]-mxs p q = filter (q `isInfixOf`) (Z12.sro_rti_related p)---- | Normalize.------ >>> pct nrm 0123456543210--- 0123456------ > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6]-nrm :: (Ord a) => [a] -> [a]-nrm = T.set---- | Normalize, retain duplicate elements.-nrm_r :: (Ord a) => [a] -> [a]-nrm_r = sort--{- | Pitch-class invariances (called @pi@ at @pct@).-->>> pct pi 0236 12-pcseg 0236-pcseg 6320-pcseg 532B-pcseg B235--> pci [1,2] [0,2,3,6] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]]---}-pci :: [Int] -> [Z12] -> [[Z12]]-pci i p =-    let f q = T.set (map (q !!) i)-    in filter (\q -> f q == f p) (Z12.sro_rti_related p)---- | Relate sets (TnMI).------ >>> pct rs 0123 641e--- T1M------ > rs [0,1,2,3] [6,4,1,11] == [(Z.tto_parse "T1M",[1,6,11,4])--- >                            ,(Z.tto_parse "T4MI",[4,11,6,1])]-rs :: [Z12] -> [Z12] -> [(Z.TTO Z12, [Z12])]-rs x y =-    let xs = map (\o -> (o,Z.z_tto_apply 5 id o x)) (Z.z_tto_univ id)-        q = T.set y-    in filter (\(_,p) -> T.set p == q) xs--rs1 :: [Z12] -> [Z12] -> Maybe (Z.TTO Z12)-rs1 p = fmap fst . headMay . rs p--{- | Relate segments.-->>> pct rsg 156 3BA-T4I--> rsg [1,5,6] [3,11,10] == [Z.sro_parse "T4I",Z.sro_parse "r1RT4MI"]-->>> pct rsg 0123 05t3-T0M--> rsg [0,1,2,3] [0,5,10,3] == [Z.sro_parse "T0M",Z.sro_parse "RT3MI"]-->>> pct rsg 0123 4e61-RT1M--> rsg [0,1,2,3] [4,11,6,1] == [Z.sro_parse "T4MI",Z.sro_parse "RT1M"]-->>> echo e614 | pct rsg 0123-r3RT1M--> rsg [0,1,2,3] [11,6,1,4] == [Z.sro_parse "r1T4MI",Z.sro_parse "r1RT1M"]---}-rsg :: [Z12] -> [Z12] -> [Z.SRO Z12]-rsg x y = filter (\o -> sro o x == y) (Z.z_sro_univ (length x) id)---- | Subsets.-sb :: [[Z12]] -> [[Z12]]-sb xs =-    let f p = all id (map (`has_sc` p) xs)-    in filter f Z12.scs--{- | scc = set class completion-->>> pct scc 6-32 168-35A-49B-3AB-34B--> scc (Z12.sc "6-32") [1,6,8] == [[3,5,10],[4,9,11],[3,10,11],[3,4,11]]---}-scc :: [Z12] -> [Z12] -> [[Z12]]-scc r p = map (\\ p) (filter (T.is_subset p) (Z12.tto_ti_related r))--si_hdr :: [String]-si_hdr =-    ["pitch-class-set"-    ,"set-class"-    ,"interval-class-vector"-    ,"tics"-    ,"complement"-    ,"multiplication-by-five-transform"]--type SI = ([Z12],Z.TTO Z12,[Z12])---- > si_raw [0,5,3,11]-si_raw :: [Z12] -> (SI,[Z12],[Int],SI,SI)-si_raw p =-    let n = length p-        p_icv = Z12.to_Z12 n : Z12.icv p-        gen_si x = let x_f = Z12.forte_prime x-                       Just x_o = rs1 x_f x-                   in (nub (sort x),x_o,x_f)-    in (gen_si p,p_icv,tics p,gen_si (Z12.complement p),gen_si (map (* 5) p))--si_raw_pp :: [Z12] -> [String]-si_raw_pp p =-    let pf_pp concise (x_o,x_f) =-            concat [Z.tto_pp x_o," ",Z12.sc_name x_f-                   ,if concise then "" else Z12.z12_vec_pp x_f]-        si_pp (x,x_o,x_f) = concat [Z12.z12_set_pp x," (",pf_pp True (x_o,x_f),")"]-        ((p',p_o,p_f),p_icv,p_tics,c,m) = si_raw p-    in [Z12.z12_set_pp p'-       ,pf_pp False (p_o,p_f)-       ,Z12.z12_vec_pp p_icv-       ,Z.z16_vec_pp p_tics-       ,si_pp c-       ,si_pp m]---- | Set information.------ > putStr $ unlines $ si [0,5,3,11]-si :: [Z12] -> [String]-si p = zipWith (\k v -> concat [k,": ",v]) si_hdr (si_raw_pp p)--{- | Super set-class.-->>> pct spsc 4-11 4-12-5-26[02458]--> spsc [Z12.sc "4-11",Z12.sc "4-12"] == [[0,2,4,5,8]]-->>> pct spsc 3-11 3-8-4-27[0258]-4-Z29[0137]--> spsc [Z12.sc "3-11",Z12.sc "3-8"] == [[0,2,5,8],[0,1,3,7]]-->>> pct spsc `pct fl 3`-6-Z17[012478]--> spsc (cf [3] Z12.scs) == [[0,1,2,4,7,8]]---}-spsc :: [[Z12]] -> [[Z12]]-spsc xs =-    let f y = all (y `has_sc`) xs-        g = (==) `on` length-    in (head . groupBy g . filter f) Z12.scs--{- | sra = stravinsky rotational array-->>> echo 019BA7 | pct sra-019BA7-08A96B-021A34-0B812A-0923B1-056243--> let r = [[0,1,9,11,10,7],[0,8,10,9,6,11],[0,2,1,10,3,4]->        ,[0,11,8,1,2,10],[0,9,2,3,11,1],[0,5,6,2,4,3]]-> in sra [0,1,9,11,10,7] == r---}-sra :: [Z12] -> [[Z12]]-sra = map (Z12.sro_tn_to 0) . T.rotations--{- | Serial operation.-->>> echo 156 | pct sro T4-59A--> sro (Z.sro_parse "T4") [1,5,6] == [5,9,10]-->>> echo 024579 | pct sro RT4I-79B024--> sro (Z.SRO 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4]-->>> echo 156 | pct sro T4I-3BA--> sro (Z.sro_parse "T4I") [1,5,6] == [3,11,10]-> sro (Z.SRO 0 False 4 False True) [1,5,6] == [3,11,10]-->>> echo 156 | pct sro T4  | pct sro T0I-732--> (sro (Z.sro_parse "T0I") . sro (Z.sro_parse "T4")) [1,5,6] == [7,3,2]-->>> echo 024579 | pct sro RT4I-79B024--> sro (Z.sro_parse "RT4I") [0,2,4,5,7,9] == [7,9,11,0,2,4]---}-sro :: Z.SRO Z12 -> [Z12] -> [Z12]-sro o = Z.z_sro_apply 5 id o---- | Vector indicating degree of intersection with inversion at each transposition.------ > tics [0,2,4,5,7,9] == [3,2,5,0,5,2,3,4,1,6,1,4]--- > map tics Z12.scs-tics :: [Z12] -> [Int]-tics p =-    let q = Z12.tto_t_related (Z12.tto_invert 0 p)-    in map (length . intersect p) q--{- | tmatrix-->>> pct tmatrix 1258--1258-0147-9A14-67A1--> tmatrix [1,2,5,8] == [[1,2,5,8],[0,1,4,7],[9,10,1,4],[6,7,10,1]]---}-tmatrix :: [Z12] -> [[Z12]]-tmatrix p =-    let i = map negate (T.d_dx p)-    in map (\n -> map (+ n) p) (T.dx_d 0 i)---{- | trs = transformations search.  Search all RTnMI of /p/ for /q/.-->>> echo 642 | pct trs 024579 | sort -u-531642-6421B9-642753-B97642--> let r = [[5,3,1,6,4,2],[6,4,2,1,11,9],[6,4,2,7,5,3],[11,9,7,6,4,2]]-> in sort (trs [0,2,4,5,7,9] [6,4,2]) == r---}-trs :: [Z12] -> [Z12] -> [[Z12]]-trs p q = filter (q `isInfixOf`) (Z12.sro_rtmi_related p)---- > trs_m [0,2,4,5,7,9] [6,4,2] == [[6,4,2,1,11,9],[11,9,7,6,4,2]]-trs_m :: [Z12] -> [Z12] -> [[Z12]]-trs_m p q = filter (q `isInfixOf`) (Z12.sro_rti_related p)
− Music/Theory/Z12/Forte_1973.hs 
@@ -1,341 +0,0 @@--- | Allen Forte. /The Structure of Atonal Music/. Yale University--- Press, New Haven, 1973.-module Music.Theory.Z12.Forte_1973 where--import qualified Music.Theory.Z.Forte_1973 as Z-import Music.Theory.Z12---- * Prime form---- | T-related rotations of /p/.------ > t_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]]-t_rotations :: [Z12] -> [[Z12]]-t_rotations = Z.t_rotations id---- | T\/I-related rotations of /p/.------ > ti_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]--- >                         ,[0,9,11],[0,2,3],[0,1,10]]-ti_rotations :: [Z12] -> [[Z12]]-ti_rotations = Z.ti_rotations id---- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'.------ > forte_prime [0,1,3,6,8,9] == [0,1,3,6,8,9]--- > forte_prime [0,2,3,6,7] == [0,1,4,5,7]-forte_prime :: [Z12] -> [Z12]-forte_prime = Z.forte_prime id---- | Transpositional equivalence prime form, ie. 't_cmp_prime' of--- 'forte_cmp'.------ > (forte_prime [0,2,3],t_prime [0,2,3]) == ([0,1,3],[0,2,3])-t_prime :: [Z12] -> [Z12]-t_prime = Z.t_prime id---- * Set Class Table--type SC_Name = Z.SC_Name---- | The set-class table (Forte prime forms).------ > length sc_table == 224-sc_table :: [(SC_Name,[Z12])]-sc_table = Z.sc_table---- | Lookup a set-class name.  The input set is subject to--- 'forte_prime' before lookup.------ > sc_name [0,2,3,6,7] == "5-Z18"--- > sc_name [0,1,4,6,7,8] == "6-Z17"-sc_name :: [Z12] -> SC_Name-sc_name = Z.sc_name id---- > sc_name_long [0,1,4,6,7,8] == "6-Z17[012478]"-sc_name_long :: [Z12] -> SC_Name-sc_name_long = Z.sc_name_long id---- | Lookup a set-class given a set-class name.------ > sc "6-Z17" == [0,1,2,4,7,8]-sc :: SC_Name -> [Z12]-sc = Z.sc--{- | List of set classes (the set class universe).--> let r = [("0-1",[0,0,0,0,0,0])->         ,("1-1",[0,0,0,0,0,0])->         ,("2-1",[1,0,0,0,0,0])->         ,("2-2",[0,1,0,0,0,0])->         ,("2-3",[0,0,1,0,0,0])->         ,("2-4",[0,0,0,1,0,0])->         ,("2-5",[0,0,0,0,1,0])->         ,("2-6",[0,0,0,0,0,1])->         ,("3-1",[2,1,0,0,0,0])->         ,("3-2",[1,1,1,0,0,0])->         ,("3-3",[1,0,1,1,0,0])->         ,("3-4",[1,0,0,1,1,0])->         ,("3-5",[1,0,0,0,1,1])->         ,("3-6",[0,2,0,1,0,0])->         ,("3-7",[0,1,1,0,1,0])->         ,("3-8",[0,1,0,1,0,1])->         ,("3-9",[0,1,0,0,2,0])->         ,("3-10",[0,0,2,0,0,1])->         ,("3-11",[0,0,1,1,1,0])->         ,("3-12",[0,0,0,3,0,0])->         ,("4-1",[3,2,1,0,0,0])->         ,("4-2",[2,2,1,1,0,0])->         ,("4-3",[2,1,2,1,0,0])->         ,("4-4",[2,1,1,1,1,0])->         ,("4-5",[2,1,0,1,1,1])->         ,("4-6",[2,1,0,0,2,1])->         ,("4-7",[2,0,1,2,1,0])->         ,("4-8",[2,0,0,1,2,1])->         ,("4-9",[2,0,0,0,2,2])->         ,("4-10",[1,2,2,0,1,0])->         ,("4-11",[1,2,1,1,1,0])->         ,("4-12",[1,1,2,1,0,1])->         ,("4-13",[1,1,2,0,1,1])->         ,("4-14",[1,1,1,1,2,0])->         ,("4-Z15",[1,1,1,1,1,1])->         ,("4-16",[1,1,0,1,2,1])->         ,("4-17",[1,0,2,2,1,0])->         ,("4-18",[1,0,2,1,1,1])->         ,("4-19",[1,0,1,3,1,0])->         ,("4-20",[1,0,1,2,2,0])->         ,("4-21",[0,3,0,2,0,1])->         ,("4-22",[0,2,1,1,2,0])->         ,("4-23",[0,2,1,0,3,0])->         ,("4-24",[0,2,0,3,0,1])->         ,("4-25",[0,2,0,2,0,2])->         ,("4-26",[0,1,2,1,2,0])->         ,("4-27",[0,1,2,1,1,1])->         ,("4-28",[0,0,4,0,0,2])->         ,("4-Z29",[1,1,1,1,1,1])->         ,("5-1",[4,3,2,1,0,0])->         ,("5-2",[3,3,2,1,1,0])->         ,("5-3",[3,2,2,2,1,0])->         ,("5-4",[3,2,2,1,1,1])->         ,("5-5",[3,2,1,1,2,1])->         ,("5-6",[3,1,1,2,2,1])->         ,("5-7",[3,1,0,1,3,2])->         ,("5-8",[2,3,2,2,0,1])->         ,("5-9",[2,3,1,2,1,1])->         ,("5-10",[2,2,3,1,1,1])->         ,("5-11",[2,2,2,2,2,0])->         ,("5-Z12",[2,2,2,1,2,1])->         ,("5-13",[2,2,1,3,1,1])->         ,("5-14",[2,2,1,1,3,1])->         ,("5-15",[2,2,0,2,2,2])->         ,("5-16",[2,1,3,2,1,1])->         ,("5-Z17",[2,1,2,3,2,0])->         ,("5-Z18",[2,1,2,2,2,1])->         ,("5-19",[2,1,2,1,2,2])->         ,("5-20",[2,1,1,2,3,1])->         ,("5-21",[2,0,2,4,2,0])->         ,("5-22",[2,0,2,3,2,1])->         ,("5-23",[1,3,2,1,3,0])->         ,("5-24",[1,3,1,2,2,1])->         ,("5-25",[1,2,3,1,2,1])->         ,("5-26",[1,2,2,3,1,1])->         ,("5-27",[1,2,2,2,3,0])->         ,("5-28",[1,2,2,2,1,2])->         ,("5-29",[1,2,2,1,3,1])->         ,("5-30",[1,2,1,3,2,1])->         ,("5-31",[1,1,4,1,1,2])->         ,("5-32",[1,1,3,2,2,1])->         ,("5-33",[0,4,0,4,0,2])->         ,("5-34",[0,3,2,2,2,1])->         ,("5-35",[0,3,2,1,4,0])->         ,("5-Z36",[2,2,2,1,2,1])->         ,("5-Z37",[2,1,2,3,2,0])->         ,("5-Z38",[2,1,2,2,2,1])->         ,("6-1",[5,4,3,2,1,0])->         ,("6-2",[4,4,3,2,1,1])->         ,("6-Z3",[4,3,3,2,2,1])->         ,("6-Z4",[4,3,2,3,2,1])->         ,("6-5",[4,2,2,2,3,2])->         ,("6-Z6",[4,2,1,2,4,2])->         ,("6-7",[4,2,0,2,4,3])->         ,("6-8",[3,4,3,2,3,0])->         ,("6-9",[3,4,2,2,3,1])->         ,("6-Z10",[3,3,3,3,2,1])->         ,("6-Z11",[3,3,3,2,3,1])->         ,("6-Z12",[3,3,2,2,3,2])->         ,("6-Z13",[3,2,4,2,2,2])->         ,("6-14",[3,2,3,4,3,0])->         ,("6-15",[3,2,3,4,2,1])->         ,("6-16",[3,2,2,4,3,1])->         ,("6-Z17",[3,2,2,3,3,2])->         ,("6-18",[3,2,2,2,4,2])->         ,("6-Z19",[3,1,3,4,3,1])->         ,("6-20",[3,0,3,6,3,0])->         ,("6-21",[2,4,2,4,1,2])->         ,("6-22",[2,4,1,4,2,2])->         ,("6-Z23",[2,3,4,2,2,2])->         ,("6-Z24",[2,3,3,3,3,1])->         ,("6-Z25",[2,3,3,2,4,1])->         ,("6-Z26",[2,3,2,3,4,1])->         ,("6-27",[2,2,5,2,2,2])->         ,("6-Z28",[2,2,4,3,2,2])->         ,("6-Z29",[2,2,4,2,3,2])->         ,("6-30",[2,2,4,2,2,3])->         ,("6-31",[2,2,3,4,3,1])->         ,("6-32",[1,4,3,2,5,0])->         ,("6-33",[1,4,3,2,4,1])->         ,("6-34",[1,4,2,4,2,2])->         ,("6-35",[0,6,0,6,0,3])->         ,("6-Z36",[4,3,3,2,2,1])->         ,("6-Z37",[4,3,2,3,2,1])->         ,("6-Z38",[4,2,1,2,4,2])->         ,("6-Z39",[3,3,3,3,2,1])->         ,("6-Z40",[3,3,3,2,3,1])->         ,("6-Z41",[3,3,2,2,3,2])->         ,("6-Z42",[3,2,4,2,2,2])->         ,("6-Z43",[3,2,2,3,3,2])->         ,("6-Z44",[3,1,3,4,3,1])->         ,("6-Z45",[2,3,4,2,2,2])->         ,("6-Z46",[2,3,3,3,3,1])->         ,("6-Z47",[2,3,3,2,4,1])->         ,("6-Z48",[2,3,2,3,4,1])->         ,("6-Z49",[2,2,4,3,2,2])->         ,("6-Z50",[2,2,4,2,3,2])->         ,("7-1",[6,5,4,3,2,1])->         ,("7-2",[5,5,4,3,3,1])->         ,("7-3",[5,4,4,4,3,1])->         ,("7-4",[5,4,4,3,3,2])->         ,("7-5",[5,4,3,3,4,2])->         ,("7-6",[5,3,3,4,4,2])->         ,("7-7",[5,3,2,3,5,3])->         ,("7-8",[4,5,4,4,2,2])->         ,("7-9",[4,5,3,4,3,2])->         ,("7-10",[4,4,5,3,3,2])->         ,("7-11",[4,4,4,4,4,1])->         ,("7-Z12",[4,4,4,3,4,2])->         ,("7-13",[4,4,3,5,3,2])->         ,("7-14",[4,4,3,3,5,2])->         ,("7-15",[4,4,2,4,4,3])->         ,("7-16",[4,3,5,4,3,2])->         ,("7-Z17",[4,3,4,5,4,1])->         ,("7-Z18",[4,3,4,4,4,2])->         ,("7-19",[4,3,4,3,4,3])->         ,("7-20",[4,3,3,4,5,2])->         ,("7-21",[4,2,4,6,4,1])->         ,("7-22",[4,2,4,5,4,2])->         ,("7-23",[3,5,4,3,5,1])->         ,("7-24",[3,5,3,4,4,2])->         ,("7-25",[3,4,5,3,4,2])->         ,("7-26",[3,4,4,5,3,2])->         ,("7-27",[3,4,4,4,5,1])->         ,("7-28",[3,4,4,4,3,3])->         ,("7-29",[3,4,4,3,5,2])->         ,("7-30",[3,4,3,5,4,2])->         ,("7-31",[3,3,6,3,3,3])->         ,("7-32",[3,3,5,4,4,2])->         ,("7-33",[2,6,2,6,2,3])->         ,("7-34",[2,5,4,4,4,2])->         ,("7-35",[2,5,4,3,6,1])->         ,("7-Z36",[4,4,4,3,4,2])->         ,("7-Z37",[4,3,4,5,4,1])->         ,("7-Z38",[4,3,4,4,4,2])->         ,("8-1",[7,6,5,4,4,2])->         ,("8-2",[6,6,5,5,4,2])->         ,("8-3",[6,5,6,5,4,2])->         ,("8-4",[6,5,5,5,5,2])->         ,("8-5",[6,5,4,5,5,3])->         ,("8-6",[6,5,4,4,6,3])->         ,("8-7",[6,4,5,6,5,2])->         ,("8-8",[6,4,4,5,6,3])->         ,("8-9",[6,4,4,4,6,4])->         ,("8-10",[5,6,6,4,5,2])->         ,("8-11",[5,6,5,5,5,2])->         ,("8-12",[5,5,6,5,4,3])->         ,("8-13",[5,5,6,4,5,3])->         ,("8-14",[5,5,5,5,6,2])->         ,("8-Z15",[5,5,5,5,5,3])->         ,("8-16",[5,5,4,5,6,3])->         ,("8-17",[5,4,6,6,5,2])->         ,("8-18",[5,4,6,5,5,3])->         ,("8-19",[5,4,5,7,5,2])->         ,("8-20",[5,4,5,6,6,2])->         ,("8-21",[4,7,4,6,4,3])->         ,("8-22",[4,6,5,5,6,2])->         ,("8-23",[4,6,5,4,7,2])->         ,("8-24",[4,6,4,7,4,3])->         ,("8-25",[4,6,4,6,4,4])->         ,("8-26",[4,5,6,5,6,2])->         ,("8-27",[4,5,6,5,5,3])->         ,("8-28",[4,4,8,4,4,4])->         ,("8-Z29",[5,5,5,5,5,3])->         ,("9-1",[8,7,6,6,6,3])->         ,("9-2",[7,7,7,6,6,3])->         ,("9-3",[7,6,7,7,6,3])->         ,("9-4",[7,6,6,7,7,3])->         ,("9-5",[7,6,6,6,7,4])->         ,("9-6",[6,8,6,7,6,3])->         ,("9-7",[6,7,7,6,7,3])->         ,("9-8",[6,7,6,7,6,4])->         ,("9-9",[6,7,6,6,8,3])->         ,("9-10",[6,6,8,6,6,4])->         ,("9-11",[6,6,7,7,7,3])->         ,("9-12",[6,6,6,9,6,3])->         ,("10-1",[9,8,8,8,8,4])->         ,("10-2",[8,9,8,8,8,4])->         ,("10-3",[8,8,9,8,8,4])->         ,("10-4",[8,8,8,9,8,4])->         ,("10-5",[8,8,8,8,9,4])->         ,("10-6",[8,8,8,8,8,5])->         ,("11-1",[10,10,10,10,10,5])->         ,("12-1",[12,12,12,12,12,6])]-> in let icvs = map icv scs in zip (map sc_name scs) icvs == r---}-scs :: [[Z12]]-scs = Z.scs---- | Cardinality /n/ subset of 'scs'.------ > map (length . scs_n) [1..11] == [1,6,12,29,38,50,38,29,12,6,1]-scs_n :: Integral i => i -> [[Z12]]-scs_n = Z.scs_n---- * BIP Metric---- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\"--- /JMT/ 17/2 (1973):234-272------ >>> pct bip 0t95728e3416--- 11223344556------ > bip [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6]--- > bip (pco "0t95728e3416") == [1,1,2,2,3,3,4,4,5,5,6]-bip :: [Z12] -> [Z12]-bip = map int_to_Z12 . Z.bip 12 . map int_from_Z12---- * ICV Metric---- | Interval class of Z12 interval /i/.------ > map ic [5,6,7] == [5,6,5]--- > map ic [-13,-1,0,1,13] == [1,1,0,1,1]-ic :: Z12 -> Z12-ic = int_to_Z12 . Z.ic 12 . int_from_Z12---- | Forte notation for interval class vector.------ > icv [0,1,2,4,7,8] == [3,2,2,3,3,2]-icv :: Integral i => [Z12] -> [i]-icv = map fromInteger . Z.icv 12 . map int_from_Z12---- | Type specialise...-icv' :: [Z12] -> [Int]-icv' = icv---- * Z-relation---- | Locate /Z/ relation of set class.------ > fmap sc_name (z_relation_of (sc "7-Z12")) == Just "7-Z36"-z_relation_of :: [Z12] -> Maybe [Z12]-z_relation_of = fmap (map int_to_Z12) . Z.z_relation_of 12 . map int_from_Z12
− Music/Theory/Z12/Lewin_1980.hs 
@@ -1,48 +0,0 @@--- | David Lewin. \"A Response to a Response: On PC Set--- Relatedness\". /Perspectives of New Music/, 18(1-2):498-502, 1980.-module Music.Theory.Z12.Lewin_1980 where--import Data.List-import qualified Music.Theory.Z12.Castren_1994 as C--type Z12 = Int---- | REL function with given /ncv/ function (see 't_rel' and 'ti_rel').-rel :: Floating n => (Int -> [a] -> [n]) -> [a] -> [a] -> n-rel ncv x y =-    let n = min (genericLength x) (genericLength y)-        p = map (`ncv` x) [2..n]-        q = map (`ncv` y) [2..n]-        f = zipWith (\i j -> sqrt (i * j))-        pt = sum (map sum p)-        qt = sum (map sum q)-    in sum (map sum (zipWith f p q)) / sqrt (pt * qt)---- | T-equivalence REL function.------ Kuusi 2001, 7.5.2------ > let (~=) p q = abs (p - q) < 1e-2--- > t_rel [0,1,2,3,4] [0,2,3,6,7] ~= 0.44--- > t_rel [0,1,2,3,4] [0,2,4,6,8] ~= 0.28--- > t_rel [0,2,3,6,7] [0,2,4,6,8] ~= 0.31-t_rel :: Floating n => [Z12] -> [Z12] -> n-t_rel = rel C.t_n_class_vector---- | T/I-equivalence REL function.------ Buchler 1998, Fig. 3.38------ > let (~=) p q = abs (p - q) < 1e-3--- > let a = [0,2,3,5,7]::[Z12]--- > let b = [0,2,3,4,5,8]::[Z12]--- > let g = [0,1,2,3,5,6,8,10]::[Z12]--- > let j = [0,2,3,4,5,6,8]::[Z12]--- > ti_rel a b ~= 0.593--- > ti_rel a g ~= 0.648--- > ti_rel a j ~= 0.509--- > ti_rel b g ~= 0.712--- > ti_rel b j ~= 0.892--- > ti_rel g j ~= 0.707-ti_rel :: Floating n => [Z12] -> [Z12] -> n-ti_rel = rel C.ti_n_class_vector
− Music/Theory/Z12/Literature.hs 
@@ -1,48 +0,0 @@--- | Z12 set class database.-module Music.Theory.Z12.Literature where---- | Set class database with descriptors for historically and--- theoretically significant set classes, indexed by Forte name.------ > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord"--- > lookup "7-35" sc_db == Just "diatonic collection (d)"-sc_db :: [(String,String)]-sc_db =-    [("4-Z15","All-Interval Tetrachord (see also 4-Z29)")-    ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)")-    ,("6-Z17","All-Trichord Hexachord")-    ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)")-    ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)")-    ,("6-1","A-Type All-Combinatorial Hexachord")-    ,("6-8","B-Type All-Combinatorial Hexachord")-    ,("6-32","C-Type All-Combinatorial Hexachord")-    ,("6-7","D-Type All-Combinatorial Hexachord")-    ,("6-20","E-Type All-Combinatorial Hexachord")-    ,("6-35","F-Type All-Combinatorial Hexachord")-    ,("7-35","diatonic collection (d)")-    ,("7-34","ascending melodic minor collection")-    ,("8-28","octotonic collection (Messiaen Mode II)")-    ,("6-35","wholetone collection")-    ,("3-10","diminished triad")-    ,("3-11","major/minor triad")-    ,("3-12","augmented triad")-    ,("4-19","minor major-seventh chord")-    ,("4-20","major-seventh chord")-    ,("4-25","french augmented sixth chord")-    ,("4-28","dimished-seventh chord")-    ,("4-26","minor-seventh chord")-    ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord")-    ,("6-30","Petrushka Chord {0476a1},3-11 at T6")-    ,("6-34","Mystic Chord {06a492}")-    ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7")-    ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB")-    ,("9-12","Messiaen Mode III (nontonic collection)")-    ,("8-9","Messian Mode IV")-    ,("7-31","The only seven-element subset of 8-28. ")-    ,("5-31","The only five-element superset of 4-28.")-    ,("5-33","The only five-element subset of 6-35.")-    ,("7-33","The only seven-element superset of 6-35.")-    ,("5-21","The only five-element subset of 6-20.")-    ,("7-21","The only seven-element superset of 6-20.")-    ,("5-25","The only five-element subset of both 7-35 and 8-28.")-    ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ]
− Music/Theory/Z12/Morris_1974.hs 
@@ -1,36 +0,0 @@--- | Robert Morris and D. Starr. \"The Structure of All-Interval Series\".--- /Journal of Music Theory/, 18:364-389, 1974.-module Music.Theory.Z12.Morris_1974 where--import qualified Control.Monad.Logic as L {- logict -}---- | 'L.msum' '.' 'map' 'return'.------ > L.observeAll (fromList [1..7]) == [1..7]-fromList :: L.MonadPlus m => [a] -> m a-fromList = L.msum . map return---- | 'L.MonadLogic' all-interval series.------ > map (length . L.observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288]--- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` L.observeAll (all_interval_m 12)--- > length (L.observeAll (all_interval_m 12)) == 3856-all_interval_m :: L.MonadLogic m => Int -> m [Int]-all_interval_m n =-    let recur k p q = -- k = length p-            if k == n-            then return (reverse p)-            else do i <- fromList [1 .. n - 1]-                    L.guard (i `notElem` p)-                    let j:_ = p-                        m = abs ((i - j) `mod` n)-                    L.guard (m `notElem` q)-                    recur (k + 1) (i : p) (m : q)-    in recur 1 [0] []---- | 'L.observeAll' of 'all_interval_m'.------ > let r = [[0,1,5,2,4,3],[0,2,1,4,5,3],[0,4,5,2,1,3],[0,5,1,4,2,3]]--- > in all_interval 6 == r-all_interval :: Int -> [[Int]]-all_interval = L.observeAll . all_interval_m
− Music/Theory/Z12/Morris_1987.hs 
@@ -1,12 +0,0 @@--- | Robert Morris. /Composition with Pitch-Classes: A Theory of--- Compositional Design/. Yale University Press, New Haven, 1987.-module Music.Theory.Z12.Morris_1987 where--import Music.Theory.List-import Music.Theory.Z12---- | @INT@ operator.------ > int [0,1,3,6,10] == [1,2,3,4]-int :: [Z12] -> [Z12]-int = d_dx
− Music/Theory/Z12/Morris_1987/Parse.hs 
@@ -1,21 +0,0 @@--- | Parsers for pitch class sets and sequences, and for 'SRO's.-module Music.Theory.Z12.Morris_1987.Parse where--import Data.Char {- base -}--import Music.Theory.Z12---- | Parse a /pitch class object/ string.  Each 'Char' is either a--- number, a space which is ignored, or a letter name for the numbers--- 10 ('t' or 'a' or 'A') or 11 ('e' or 'B' or 'b').------ > pco "13te" == [1,3,10,11]--- > pco "13te" == pco "13ab"-pco :: String -> [Z12]-pco s =-    let s' = dropWhile isSpace s-        s'' = takeWhile (`elem` "0123456789taAebB") s'-        f c | c `elem` "taA" = 10-            | c `elem` "ebB" = 11-            | otherwise = fromInteger (read [c])-    in map f s''
− Music/Theory/Z12/Rahn_1980.hs 
@@ -1,25 +0,0 @@--- | John Rahn. /Basic Atonal Theory/. Longman, New York, 1980.-module Music.Theory.Z12.Rahn_1980 where--import Music.Theory.Z12-import qualified Music.Theory.Z.Forte_1973 as Z---- | Rahn prime form (comparison is rightmost inwards).------ > rahn_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == GT-rahn_cmp :: Ord a => [a] -> [a] -> Ordering-rahn_cmp p q = compare (reverse p) (reverse q)---- | Rahn prime form, ie. 'ti_cmp_prime' of 'rahn_cmp'.------ > rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9]------ > import Music.Theory.Z12.Forte_1973------ > let s = [[0,1,3,7,8]--- >         ,[0,1,3,6,8,9],[0,1,3,5,8,9]--- >         ,[0,1,2,4,7,8,9]--- >         ,[0,1,2,4,5,7,9,10]]--- > in all (\p -> forte_prime p /= rahn_prime p) s == True-rahn_prime :: [Z12] -> [Z12]-rahn_prime = Z.ti_cmp_prime id rahn_cmp
− Music/Theory/Z12/Read_1978.hs 
@@ -1,28 +0,0 @@--- | Ronald C. Read. \"Every one a winner or how to avoid isomorphism--- search when cataloguing combinatorial configurations.\" /Annals of--- Discrete Mathematics/ 2:107–20, 1978.-module Music.Theory.Z12.Read_1978 where--import Music.Theory.Z12 {- hmt -}-import qualified Music.Theory.Z.Read_1978 as Z {- hmt -}--type Code = Z.Code---- | Encoder for 'encode_prime'.------ > encode [0,1,3,6,8,9] == 843-encode :: [Z12] -> Code-encode = Z.encode---- | Decoder for 'encode_prime'.------ > decode 843 == [0,1,3,6,8,9]-decode :: Code -> [Z12]-decode = Z.decode 12---- | Binary encoding prime form algorithm, equalivalent to Rahn.------ > encode_prime [0,1,3,6,8,9] == [0,2,3,6,7,9]--- > Music.Theory.Z12.Rahn_1980.rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9]-encode_prime :: [Z12] -> [Z12]-encode_prime = Z.encode_prime id
− Music/Theory/Z12/SRO.hs 
@@ -1,97 +0,0 @@--- | Serial (ordered) pitch-class operations on 'Z12'.-module Music.Theory.Z12.SRO where--import Data.List {- base -}--import qualified Music.Theory.List as T-import qualified Music.Theory.Z.SRO as Z-import           Music.Theory.Z12---- | Transpose /p/ by /n/.------ > sro_tn 4 [1,5,6] == [5,9,10]-sro_tn :: Z12 -> [Z12] -> [Z12]-sro_tn = Z.z_sro_tn id---- | Invert /p/ about /n/.------ > sro_invert 6 [4,5,6] == [8,7,6]--- > sro_invert 0 [0,1,3] == [0,11,9]-sro_invert :: Z12 -> [Z12] -> [Z12]-sro_invert = Z.z_sro_invert id---- | Composition of 'invert' about @0@ and 'tn'.------ > tni 4 [1,5,6] == [3,11,10]--- > (sro_invert 0 . sro_tn  4) [1,5,6] == [7,3,2]-sro_tni :: Z12 -> [Z12] -> [Z12]-sro_tni = Z.z_sro_tni id---- | Modulo 12 multiplication------ > sro_mn 11 [0,1,4,9] == sro_tni 0 [0,1,4,9]-sro_mn :: Z12 -> [Z12] -> [Z12]-sro_mn = Z.z_sro_mn id---- | M5, ie. 'mn' @5@.------ > sro_m5 [0,1,3] == [0,5,3]-sro_m5 :: [Z12] -> [Z12]-sro_m5 = sro_mn 5---- | T-related sequences of /p/.------ > length (sro_t_related [0,3,6,9]) == 12-sro_t_related :: [Z12] -> [[Z12]]-sro_t_related = Z.z_sro_t_related id---- | T\/I-related sequences of /p/.------ > length (ti_related [0,1,3]) == 24--- > length (ti_related [0,3,6,9]) == 24--- > ti_related [0] == map return [0..11]-sro_ti_related :: [Z12] -> [[Z12]]-sro_ti_related = Z.z_sro_ti_related id---- | R\/T\/I-related sequences of /p/.------ > length (rti_related [0,1,3]) == 48--- > length (rti_related [0,3,6,9]) == 24-sro_rti_related :: [Z12] -> [[Z12]]-sro_rti_related = Z.z_sro_rti_related id---- | T\/M\/I-related sequences of /p/, duplicates removed.-sro_tmi_related :: [Z12] -> [[Z12]]-sro_tmi_related p = let q = sro_ti_related p in nub (q ++ map sro_m5 q)---- | R\/T\/M\/I-related sequences of /p/, duplicates removed.-sro_rtmi_related :: [Z12] -> [[Z12]]-sro_rtmi_related p = let q = sro_tmi_related p in nub (q ++ map reverse q)---- | r\/R\/T\/M\/I-related sequences of /p/, duplicates removed.-sro_rrtmi_related :: [Z12] -> [[Z12]]-sro_rrtmi_related p = nub (concatMap sro_rtmi_related (T.rotations p))---- * Sequence operations---- | Variant of 'tn', transpose /p/ so first element is /n/.------ > sro_tn_to 5 [0,1,3] == [5,6,8]--- > map (sro_tn_to 0) [[0,1,3],[1,3,0],[3,0,1]] == [[0,1,3],[0,2,11],[0,9,10]]-sro_tn_to :: Z12 -> [Z12] -> [Z12]-sro_tn_to = Z.z_sro_tn_to id---- | Variant of 'invert', inverse about /n/th element.------ > map (sro_invert_ix 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]]--- > map (sro_invert_ix 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]]-sro_invert_ix :: Int -> [Z12] -> [Z12]-sro_invert_ix = Z.z_sro_invert_ix id---- | The standard t-matrix of /p/.------ > tmatrix [0,1,3] == [[0,1,3]--- >                    ,[11,0,2]--- >                    ,[9,10,0]]-tmatrix :: [Z12] -> [[Z12]]-tmatrix = Z.z_tmatrix id
− Music/Theory/Z12/TTO.hs 
@@ -1,59 +0,0 @@--- | Pitch-class set (unordered) operations on 'Z12'.-module Music.Theory.Z12.TTO where--import Data.List {- base -}--import Music.Theory.Z12---- | Map to pitch-class and reduce to set.------ > pcset [1,13] == [1]-pcset :: (Integral a) => [a] -> [Z12]-pcset = nub . sort . map fromIntegral---- | Transpose by n.------ > tto_tn 4 [1,5,6] == [5,9,10]--- > tto_tn 4 [0,4,8] == [0,4,8]-tto_tn :: Z12 -> [Z12] -> [Z12]-tto_tn n = sort . map (+ n)---- | Invert about n.------ > tto_invert 6 [4,5,6] == [6,7,8]--- > tto_invert 0 [0,1,3] == [0,9,11]-tto_invert :: Z12 -> [Z12] -> [Z12]-tto_invert n = sort . map (\p -> n - (p - n))---- | Composition of 'invert' about @0@ and 'tn'.------ > tto_tni 4 [1,5,6] == [3,10,11]--- > (tto_invert 0 . tto_tn 4) [1,5,6] == [2,3,7]-tto_tni :: Z12 -> [Z12] -> [Z12]-tto_tni n = tto_tn n . tto_invert 0---- | Modulo 12 multiplication------ > tto_mn 11 [0,1,4,9] == tto_invert 0 [0,1,4,9]-tto_mn :: Z12 -> [Z12] -> [Z12]-tto_mn n = sort . map (* n)---- | M5, ie. 'mn' @5@.------ > tto_m5 [0,1,3] == [0,3,5]-tto_m5 :: [Z12] -> [Z12]-tto_m5 = tto_mn 5---- | T-related sets of /p/.------ > length (tto_t_related [0,1,3]) == 12--- > tto_t_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]-tto_t_related :: [Z12] -> [[Z12]]-tto_t_related p = nub (map (`tto_tn` p) [0..11])---- | T\/I-related set of /p/.------ > length (tto_ti_related [0,1,3]) == 24--- > tto_ti_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]-tto_ti_related :: [Z12] -> [[Z12]]-tto_ti_related p = nub (tto_t_related p ++ tto_t_related (tto_invert 0 p))
README view
@@ -1,21 +1,21 @@ hmt - haskell music theory -------------------------- -Music theory operations in [haskell][hs], primarily focused on 'set-theory' and 'common music notation'.+[haskell](http://haskell.org/) music theory -- [hmt-diagrams][hmt-diagrams]+related: +- [hmt-diagrams](?t=hmt-diagrams)+- [hmt-texts](?t=hmt-texts)+ ## cli +[csv-midi](?t=hmt&e=md/csv-midi.md), [db](?t=hmt&e=md/db.md),+[gl](?t=hmt&e=md/gl.md),+[obj](?t=hmt&e=md/obj.md), [pct](?t=hmt&e=md/pct.md),+[ply](?t=hmt&e=md/ply.md), [scala](?t=hmt&e=md/scala.md) -[hs]: http://haskell.org/-[hmt-diagrams]:  http://rd.slavepianos.org/?t=hmt-diagrams--© [rohan drape][rd], 2006-2017, [gpl][gpl].--[rd]:  http://rd.slavepianos.org/-[gpl]: http://gnu.org/copyleft/+© [rohan drape](http://rohandrape.net/), 2006-2020, [gpl](http://gnu.org/copyleft/).
+ data/csv/mnd/all-notes-off.csv view
@@ -0,0 +1,129 @@+time,on/off,note,velocity,channel,param+0.0000,off,0,0,0,+0.0100,off,1,0,0,+0.0200,off,2,0,0,+0.0300,off,3,0,0,+0.0400,off,4,0,0,+0.0500,off,5,0,0,+0.0600,off,6,0,0,+0.0700,off,7,0,0,+0.0800,off,8,0,0,+0.0900,off,9,0,0,+0.1000,off,10,0,0,+0.1100,off,11,0,0,+0.1200,off,12,0,0,+0.1300,off,13,0,0,+0.1400,off,14,0,0,+0.1500,off,15,0,0,+0.1600,off,16,0,0,+0.1700,off,17,0,0,+0.1800,off,18,0,0,+0.1900,off,19,0,0,+0.2000,off,20,0,0,+0.2100,off,21,0,0,+0.2200,off,22,0,0,+0.2300,off,23,0,0,+0.2400,off,24,0,0,+0.2500,off,25,0,0,+0.2600,off,26,0,0,+0.2700,off,27,0,0,+0.2800,off,28,0,0,+0.2900,off,29,0,0,+0.3000,off,30,0,0,+0.3100,off,31,0,0,+0.3200,off,32,0,0,+0.3300,off,33,0,0,+0.3400,off,34,0,0,+0.3500,off,35,0,0,+0.3600,off,36,0,0,+0.3700,off,37,0,0,+0.3800,off,38,0,0,+0.3900,off,39,0,0,+0.4000,off,40,0,0,+0.4100,off,41,0,0,+0.4200,off,42,0,0,+0.4300,off,43,0,0,+0.4400,off,44,0,0,+0.4500,off,45,0,0,+0.4600,off,46,0,0,+0.4700,off,47,0,0,+0.4800,off,48,0,0,+0.4900,off,49,0,0,+0.5000,off,50,0,0,+0.5100,off,51,0,0,+0.5200,off,52,0,0,+0.5300,off,53,0,0,+0.5400,off,54,0,0,+0.5500,off,55,0,0,+0.5600,off,56,0,0,+0.5700,off,57,0,0,+0.5800,off,58,0,0,+0.5900,off,59,0,0,+0.6000,off,60,0,0,+0.6100,off,61,0,0,+0.6200,off,62,0,0,+0.6300,off,63,0,0,+0.6400,off,64,0,0,+0.6500,off,65,0,0,+0.6600,off,66,0,0,+0.6700,off,67,0,0,+0.6800,off,68,0,0,+0.6900,off,69,0,0,+0.7000,off,70,0,0,+0.7100,off,71,0,0,+0.7200,off,72,0,0,+0.7300,off,73,0,0,+0.7400,off,74,0,0,+0.7500,off,75,0,0,+0.7600,off,76,0,0,+0.7700,off,77,0,0,+0.7800,off,78,0,0,+0.7900,off,79,0,0,+0.8000,off,80,0,0,+0.8100,off,81,0,0,+0.8200,off,82,0,0,+0.8300,off,83,0,0,+0.8400,off,84,0,0,+0.8500,off,85,0,0,+0.8600,off,86,0,0,+0.8700,off,87,0,0,+0.8800,off,88,0,0,+0.8900,off,89,0,0,+0.9000,off,90,0,0,+0.9100,off,91,0,0,+0.9200,off,92,0,0,+0.9300,off,93,0,0,+0.9400,off,94,0,0,+0.9500,off,95,0,0,+0.9600,off,96,0,0,+0.9700,off,97,0,0,+0.9800,off,98,0,0,+0.9900,off,99,0,0,+1.0000,off,100,0,0,+1.0100,off,101,0,0,+1.0200,off,102,0,0,+1.0300,off,103,0,0,+1.0400,off,104,0,0,+1.0500,off,105,0,0,+1.0600,off,106,0,0,+1.0700,off,107,0,0,+1.0800,off,108,0,0,+1.0900,off,109,0,0,+1.1000,off,110,0,0,+1.1100,off,111,0,0,+1.1200,off,112,0,0,+1.1300,off,113,0,0,+1.1400,off,114,0,0,+1.1500,off,115,0,0,+1.1600,off,116,0,0,+1.1700,off,117,0,0,+1.1800,off,118,0,0,+1.1900,off,119,0,0,+1.2000,off,120,0,0,+1.2100,off,121,0,0,+1.2200,off,122,0,0,+1.2300,off,123,0,0,+1.2400,off,124,0,0,+1.2500,off,125,0,0,+1.2600,off,126,0,0,+1.2700,off,127,0,0,
− data/dot/euler-j5-a.dot 
@@ -1,30 +0,0 @@-graph g {-graph [layout="dot",rankdir="TB",nodesep=0.5];-edge [fontsize="8",fontname="century schoolbook"];-node [shape="plaintext",fontsize="10",fontname="century schoolbook"];-R_5_3 [label="A♮\n5:3"];-R_5_4 [label="E♮\n5:4"];-R_15_8 [label="B♮\n15:8"];-R_16_9 [label="B♭\n16:9"];-R_4_3 [label="F♮\n4:3"];-R_1_1 [label="C♮\n1:1"];-R_3_2 [label="G♮\n3:2"];-R_9_8 [label="D♮\n9:8"];-R_64_45 [label="F♯\n64:45"];-R_16_15 [label="C♯\n16:15"];-R_8_5 [label="A♭\n8:5"];-R_6_5 [label="E♭\n6:5"];-R_5_3 -- R_5_4 -- R_15_8;-R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8;-R_64_45 -- R_16_15 -- R_8_5 -- R_6_5;-R_4_3 -- R_5_3 [label="   (8:5)"];-R_1_1 -- R_5_4 [label="   (8:5)"];-R_3_2 -- R_15_8 [label="   (8:5)"];-R_64_45 -- R_16_9 [label="   (8:5)"];-R_16_15 -- R_4_3 [label="   (8:5)"];-R_8_5 -- R_1_1 [label="   (8:5)"];-R_6_5 -- R_3_2 [label="   (8:5)"];-{rank=min; R_5_3 R_5_4 R_15_8}-{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8}-{rank=max; R_64_45 R_16_15 R_8_5 R_6_5}-}
− data/dot/euler-j5-b.dot 
@@ -1,30 +0,0 @@-graph g {-graph [layout="dot",rankdir="TB",nodesep=0.5];-edge [fontsize="8",fontname="century schoolbook"];-node [shape="plaintext",fontsize="10",fontname="century schoolbook"];-R_5_3 [label="A♮\n5:3"];-R_5_4 [label="E♮\n5:4"];-R_15_8 [label="B♮\n15:8"];-R_45_32 [label="F♯\n45:32"];-R_16_9 [label="B♭\n16:9"];-R_4_3 [label="F♮\n4:3"];-R_1_1 [label="C♮\n1:1"];-R_3_2 [label="G♮\n3:2"];-R_9_8 [label="D♮\n9:8"];-R_16_15 [label="C♯\n16:15"];-R_8_5 [label="A♭\n8:5"];-R_6_5 [label="E♭\n6:5"];-R_5_3 -- R_5_4 -- R_15_8 -- R_45_32;-R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8;-R_16_15 -- R_8_5 -- R_6_5;-R_4_3 -- R_5_3 [label="   (8:5)"];-R_1_1 -- R_5_4 [label="   (8:5)"];-R_3_2 -- R_15_8 [label="   (8:5)"];-R_9_8 -- R_45_32 [label="   (8:5)"];-R_16_15 -- R_4_3 [label="   (8:5)"];-R_8_5 -- R_1_1 [label="   (8:5)"];-R_6_5 -- R_3_2 [label="   (8:5)"];-{rank=min; R_5_3 R_5_4 R_15_8 R_45_32}-{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8}-{rank=max; R_16_15 R_8_5 R_6_5}-}
− data/dot/euler-j7.dot 
@@ -1,29 +0,0 @@-graph g {-graph [layout="dot",rankdir="TB",nodesep=0.5];-edge [fontsize="8",fontname="century schoolbook"];-node [shape="plaintext",fontsize="10",fontname="century schoolbook"];-R_5_4 [label="E♮\n5:4"];-R_15_8 [label="B♮\n15:8"];-R_45_32 [label="F♯\n45:32"];-R_135_128 [label="C♯\n135:128"];-R_4_3 [label="F♮\n4:3"];-R_1_1 [label="C♮\n1:1"];-R_3_2 [label="G♮\n3:2"];-R_9_8 [label="D♮\n9:8"];-R_27_16 [label="A♮\n27:16"];-R_14_9 [label="A♭\n14:9"];-R_7_6 [label="E♭\n7:6"];-R_7_4 [label="B♭\n7:4"];-R_5_4 -- R_15_8 -- R_45_32 -- R_135_128;-R_4_3 -- R_1_1 -- R_3_2 -- R_9_8 -- R_27_16;-R_14_9 -- R_7_6 -- R_7_4;-R_1_1 -- R_5_4 [label="   (8:5)"];-R_3_2 -- R_15_8 [label="   (8:5)"];-R_9_8 -- R_45_32 [label="   (8:5)"];-R_27_16 -- R_135_128 [label="   (8:5)"];-R_7_6 -- R_4_3 [label="   (7:4)"];-R_7_4 -- R_1_1 [label="   (7:4)"];-{rank=min; R_5_4 R_15_8 R_45_32 R_135_128}-{rank=same; R_4_3 R_1_1 R_3_2 R_9_8 R_27_16}-{rank=max; R_14_9 R_7_6 R_7_4}-}
− data/dot/euler-wtp.dot 
@@ -1,30 +0,0 @@-graph g {-graph [layout="dot",rankdir="TB",nodesep=0.5];-edge [fontsize="8",fontname="century schoolbook"];-node [shape="plaintext",fontsize="10",fontname="century schoolbook"];-R_49_32 [label="B♭=738\n49:32"];-R_147_128 [label="F♮=240\n147:128"];-R_441_256 [label="C♮=942\n441:256"];-R_1323_1024 [label="G♮=444\n1323:1024"];-R_7_4 [label="C♯=969\n7:4"];-R_21_16 [label="A♭=471\n21:16"];-R_63_32 [label="E♭=1173\n63:32"];-R_189_128 [label="B♭=675\n189:128"];-R_567_512 [label="F♮=177\n567:512"];-R_1_1 [label="E♭=0\n1:1"];-R_3_2 [label="B♭=702\n3:2"];-R_9_8 [label="F♮=204\n9:8"];-R_49_32 -- R_147_128 -- R_441_256 -- R_1323_1024;-R_7_4 -- R_21_16 -- R_63_32 -- R_189_128 -- R_567_512;-R_1_1 -- R_3_2 -- R_9_8;-R_7_4 -- R_49_32 [label="   (8:7)"];-R_21_16 -- R_147_128 [label="   (8:7)"];-R_63_32 -- R_441_256 [label="   (8:7)"];-R_189_128 -- R_1323_1024 [label="   (8:7)"];-R_1_1 -- R_7_4 [label="   (8:7)"];-R_3_2 -- R_21_16 [label="   (8:7)"];-R_9_8 -- R_63_32 [label="   (8:7)"];-{rank=min; R_49_32 R_147_128 R_441_256 R_1323_1024}-{rank=same; R_7_4 R_21_16 R_63_32 R_189_128 R_567_512}-{rank=max; R_1_1 R_3_2 R_9_8}-}
+ data/dot/euler/euler-j5-a.dot view
@@ -0,0 +1,30 @@+graph g {+graph [layout="dot",rankdir="TB",nodesep=0.5];+edge [fontsize="8",fontname="century schoolbook"];+node [shape="plaintext",fontsize="10",fontname="century schoolbook"];+R_5_3 [label="A♮\n5:3"];+R_5_4 [label="E♮\n5:4"];+R_15_8 [label="B♮\n15:8"];+R_16_9 [label="B♭\n16:9"];+R_4_3 [label="F♮\n4:3"];+R_1_1 [label="C♮\n1:1"];+R_3_2 [label="G♮\n3:2"];+R_9_8 [label="D♮\n9:8"];+R_64_45 [label="F♯\n64:45"];+R_16_15 [label="C♯\n16:15"];+R_8_5 [label="A♭\n8:5"];+R_6_5 [label="E♭\n6:5"];+R_5_3 -- R_5_4 -- R_15_8;+R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8;+R_64_45 -- R_16_15 -- R_8_5 -- R_6_5;+R_4_3 -- R_5_3 [label="   (8:5)"];+R_1_1 -- R_5_4 [label="   (8:5)"];+R_3_2 -- R_15_8 [label="   (8:5)"];+R_64_45 -- R_16_9 [label="   (8:5)"];+R_16_15 -- R_4_3 [label="   (8:5)"];+R_8_5 -- R_1_1 [label="   (8:5)"];+R_6_5 -- R_3_2 [label="   (8:5)"];+{rank=min; R_5_3 R_5_4 R_15_8}+{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8}+{rank=max; R_64_45 R_16_15 R_8_5 R_6_5}+}
+ data/dot/euler/euler-j5-b.dot view
@@ -0,0 +1,30 @@+graph g {+graph [layout="dot",rankdir="TB",nodesep=0.5];+edge [fontsize="8",fontname="century schoolbook"];+node [shape="plaintext",fontsize="10",fontname="century schoolbook"];+R_5_3 [label="A♮\n5:3"];+R_5_4 [label="E♮\n5:4"];+R_15_8 [label="B♮\n15:8"];+R_45_32 [label="F♯\n45:32"];+R_16_9 [label="B♭\n16:9"];+R_4_3 [label="F♮\n4:3"];+R_1_1 [label="C♮\n1:1"];+R_3_2 [label="G♮\n3:2"];+R_9_8 [label="D♮\n9:8"];+R_16_15 [label="C♯\n16:15"];+R_8_5 [label="A♭\n8:5"];+R_6_5 [label="E♭\n6:5"];+R_5_3 -- R_5_4 -- R_15_8 -- R_45_32;+R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8;+R_16_15 -- R_8_5 -- R_6_5;+R_4_3 -- R_5_3 [label="   (8:5)"];+R_1_1 -- R_5_4 [label="   (8:5)"];+R_3_2 -- R_15_8 [label="   (8:5)"];+R_9_8 -- R_45_32 [label="   (8:5)"];+R_16_15 -- R_4_3 [label="   (8:5)"];+R_8_5 -- R_1_1 [label="   (8:5)"];+R_6_5 -- R_3_2 [label="   (8:5)"];+{rank=min; R_5_3 R_5_4 R_15_8 R_45_32}+{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8}+{rank=max; R_16_15 R_8_5 R_6_5}+}
+ data/dot/euler/euler-j7.dot view
@@ -0,0 +1,29 @@+graph g {+graph [layout="dot",rankdir="TB",nodesep=0.5];+edge [fontsize="8",fontname="century schoolbook"];+node [shape="plaintext",fontsize="10",fontname="century schoolbook"];+R_5_4 [label="E♮\n5:4"];+R_15_8 [label="B♮\n15:8"];+R_45_32 [label="F♯\n45:32"];+R_135_128 [label="C♯\n135:128"];+R_4_3 [label="F♮\n4:3"];+R_1_1 [label="C♮\n1:1"];+R_3_2 [label="G♮\n3:2"];+R_9_8 [label="D♮\n9:8"];+R_27_16 [label="A♮\n27:16"];+R_14_9 [label="A♭\n14:9"];+R_7_6 [label="E♭\n7:6"];+R_7_4 [label="B♭\n7:4"];+R_5_4 -- R_15_8 -- R_45_32 -- R_135_128;+R_4_3 -- R_1_1 -- R_3_2 -- R_9_8 -- R_27_16;+R_14_9 -- R_7_6 -- R_7_4;+R_1_1 -- R_5_4 [label="   (8:5)"];+R_3_2 -- R_15_8 [label="   (8:5)"];+R_9_8 -- R_45_32 [label="   (8:5)"];+R_27_16 -- R_135_128 [label="   (8:5)"];+R_7_6 -- R_4_3 [label="   (7:4)"];+R_7_4 -- R_1_1 [label="   (7:4)"];+{rank=min; R_5_4 R_15_8 R_45_32 R_135_128}+{rank=same; R_4_3 R_1_1 R_3_2 R_9_8 R_27_16}+{rank=max; R_14_9 R_7_6 R_7_4}+}
+ data/dot/euler/euler-wtp.dot view
@@ -0,0 +1,30 @@+graph g {+graph [layout="dot",rankdir="TB",nodesep=0.5];+edge [fontsize="8",fontname="century schoolbook"];+node [shape="plaintext",fontsize="10",fontname="century schoolbook"];+R_49_32 [label="B♭=738\n49:32"];+R_147_128 [label="F♮=240\n147:128"];+R_441_256 [label="C♮=942\n441:256"];+R_1323_1024 [label="G♮=444\n1323:1024"];+R_7_4 [label="C♯=969\n7:4"];+R_21_16 [label="A♭=471\n21:16"];+R_63_32 [label="E♭=1173\n63:32"];+R_189_128 [label="B♭=675\n189:128"];+R_567_512 [label="F♮=177\n567:512"];+R_1_1 [label="E♭=0\n1:1"];+R_3_2 [label="B♭=702\n3:2"];+R_9_8 [label="F♮=204\n9:8"];+R_49_32 -- R_147_128 -- R_441_256 -- R_1323_1024;+R_7_4 -- R_21_16 -- R_63_32 -- R_189_128 -- R_567_512;+R_1_1 -- R_3_2 -- R_9_8;+R_7_4 -- R_49_32 [label="   (8:7)"];+R_21_16 -- R_147_128 [label="   (8:7)"];+R_63_32 -- R_441_256 [label="   (8:7)"];+R_189_128 -- R_1323_1024 [label="   (8:7)"];+R_1_1 -- R_7_4 [label="   (8:7)"];+R_3_2 -- R_21_16 [label="   (8:7)"];+R_9_8 -- R_63_32 [label="   (8:7)"];+{rank=min; R_49_32 R_147_128 R_441_256 R_1323_1024}+{rank=same; R_7_4 R_21_16 R_63_32 R_189_128 R_567_512}+{rank=max; R_1_1 R_3_2 R_9_8}+}
− data/dot/tj_oh_p012.dot 
@@ -1,30 +0,0 @@-graph g {-graph [layout="dot",rankdir="TB",nodesep=0.5];-edge [fontsize="8",fontname="century schoolbook"];-node [shape="plaintext",fontsize="10",fontname="century schoolbook"];-R_5_3 [label="A♮=884\n5:3"];-R_5_4 [label="E♮=386\n5:4"];-R_15_8 [label="B♮=1088\n15:8"];-R_45_32 [label="F♯=590\n45:32"];-R_16_9 [label="B♭=996\n16:9"];-R_4_3 [label="F♮=498\n4:3"];-R_1_1 [label="C♮=0\n1:1"];-R_3_2 [label="G♮=702\n3:2"];-R_9_8 [label="D♮=204\n9:8"];-R_16_15 [label="C♯=112\n16:15"];-R_8_5 [label="A♭=814\n8:5"];-R_6_5 [label="E♭=316\n6:5"];-R_5_3 -- R_5_4 -- R_15_8 -- R_45_32;-R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8;-R_16_15 -- R_8_5 -- R_6_5;-R_4_3 -- R_5_3 [label="   (8:5)"];-R_1_1 -- R_5_4 [label="   (8:5)"];-R_3_2 -- R_15_8 [label="   (8:5)"];-R_9_8 -- R_45_32 [label="   (8:5)"];-R_16_15 -- R_4_3 [label="   (8:5)"];-R_8_5 -- R_1_1 [label="   (8:5)"];-R_6_5 -- R_3_2 [label="   (8:5)"];-{rank=min; R_5_3 R_5_4 R_15_8 R_45_32}-{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8}-{rank=max; R_16_15 R_8_5 R_6_5}-}
− data/dot/tj_oh_p014.dot 
@@ -1,58 +0,0 @@-graph- g {-graph [start=168732,layout=neato,epsilon=0.000001];-node [shape=plaintext,fontsize=10,fontname="century schoolbook"];-0 [label="C♮"];-1 [label="c♮"];-2 [label="C♯"];-3 [label="c♯"];-4 [label="D♮"];-5 [label="d♮"];-6 [label="E♭"];-7 [label="e♭"];-8 [label="E♮"];-9 [label="e♮"];-10 [label="F♮"];-11 [label="f♮"];-12 [label="F♯"];-13 [label="f♯"];-14 [label="G♮"];-15 [label="g♮"];-16 [label="A♭"];-17 [label="a♭"];-18 [label="A♮"];-19 [label="a♮"];-20 [label="B♮"];-21 [label="b♮"];-22 [label="b♭"];-23 [label="B♭"];-0 -- 1;-0 -- 9;-0 -- 19;-2 -- 3;-2 -- 11;-2 -- 22;-4 -- 5;-4 -- 21;-6 -- 1;-6 -- 7;-6 -- 15;-8 -- 3;-8 -- 9;-8 -- 17;-10 -- 11;-12 -- 13;-12 -- 22;-14 -- 9;-14 -- 15;-14 -- 21;-16 -- 11;-16 -- 17;-18 -- 3;-18 -- 13;-18 -- 19;-20 -- 17;-20 -- 21;-23 -- 5;-23 -- 15;-}
− data/dot/tj_oh_p031.dot 
@@ -1,53 +0,0 @@-graph- g {-graph [layout=neato,epsilon=0.000001];-node [shape=plaintext,fontsize=10,fontname="century schoolbook"];-0 [label="0,2,4,7"];-1 [label="0,2,7,10"];-2 [label="0,2,4,9"];-3 [label="1,3,5,8"];-4 [label="1,3,8,11"];-5 [label="1,3,5,10"];-6 [label="2,4,6,9"];-7 [label="2,4,6,11"];-8 [label="0,5,7,9"];-9 [label="2,5,7,9"];-10 [label="1,6,8,10"];-11 [label="3,6,8,10"];-12 [label="2,7,9,11"];-13 [label="4,7,9,11"];-14 [label="0,3,8,10"];-15 [label="0,5,8,10"];-16 [label="1,4,9,11"];-17 [label="1,6,9,11"];-18 [label="0,2,5,10"];-19 [label="1,3,6,11"];-20 [label="3,5,7,10"];-21 [label="4,6,8,11"];-22 [label="0,3,5,7"];-23 [label="1,4,6,8"];-0 -- 1;-0 -- 2;-2 -- 6;-3 -- 4;-3 -- 5;-5 -- 20;-6 -- 7;-7 -- 21;-8 -- 9;-9 -- 12;-10 -- 11;-12 -- 13;-14 -- 11;-14 -- 15;-16 -- 13;-16 -- 17;-18 -- 1;-18 -- 15;-19 -- 4;-19 -- 17;-22 -- 8;-22 -- 20;-23 -- 10;-23 -- 21;-}
− data/dot/tj_oh_p125.dot 
@@ -1,72 +0,0 @@-graph- g {-graph [layout=neato,epsilon=0.000001];-node [shape=plaintext,fontsize=10,fontname="century schoolbook"];-0 [label="0,4,11"];-1 [label="0,5,11"];-2 [label="1,4,11"];-3 [label="0,5,10"];-4 [label="0,6,10"];-5 [label="1,5,10"];-6 [label="0,6,9"];-7 [label="0,7,9"];-8 [label="1,6,9"];-9 [label="0,7,8"];-10 [label="1,7,8"];-11 [label="1,3,11"];-12 [label="2,3,11"];-13 [label="1,4,10"];-14 [label="2,4,10"];-15 [label="1,5,9"];-16 [label="2,5,9"];-17 [label="1,6,8"];-18 [label="2,6,8"];-19 [label="2,3,10"];-20 [label="2,4,9"];-21 [label="3,4,9"];-22 [label="2,5,8"];-23 [label="3,5,8"];-24 [label="2,6,7"];-25 [label="3,6,7"];-26 [label="3,4,8"];-27 [label="3,5,7"];-28 [label="4,5,7"];-29 [label="4,5,6"];-0 -- 1;-0 -- 2;-3 -- 1;-3 -- 4;-3 -- 5;-6 -- 4;-6 -- 7;-6 -- 8;-9 -- 7;-9 -- 10;-11 -- 2;-11 -- 12;-13 -- 2;-13 -- 5;-13 -- 14;-15 -- 5;-15 -- 8;-15 -- 16;-17 -- 8;-17 -- 10;-17 -- 18;-19 -- 12;-19 -- 14;-20 -- 14;-20 -- 16;-20 -- 21;-22 -- 16;-22 -- 18;-22 -- 23;-24 -- 18;-24 -- 25;-26 -- 21;-26 -- 23;-27 -- 23;-27 -- 25;-27 -- 28;-29 -- 28;-}
− data/dot/tj_oh_p131.dot 
@@ -1,26 +0,0 @@-graph- g {-graph [layout=neato,epsilon=0.000001];-node [shape=plaintext,fontsize=10,fontname="century schoolbook"];-0 [label="6,10,14"];-1 [label="6,11,13"];-2 [label="7,9,14"];-3 [label="7,10,13"];-4 [label="7,11,12"];-5 [label="8,9,13"];-6 [label="8,10,12"];-7 [label="9,10,11"];-0 -- 1;-0 -- 2;-0 -- 3;-1 -- 3;-1 -- 4;-2 -- 3;-2 -- 5;-3 -- 4;-3 -- 5;-3 -- 6;-4 -- 6;-5 -- 6;-6 -- 7;-}
− data/dot/tj_oh_p162.dot 
@@ -1,83 +0,0 @@-graph- g {-edge [len=1.75];-graph [layout=neato,epsilon=0.000001];-node [shape=plaintext,fontsize=10,fontname="century schoolbook"];-0 [label="0,1,2,6"];-1 [label="0,2,5,6"];-2 [label="1,2,4,6"];-3 [label="1,2,6,8"];-4 [label="0,1,3,5"];-5 [label="0,1,5,7"];-6 [label="1,3,4,5"];-7 [label="1,3,5,8"];-8 [label="0,1,4,8"];-9 [label="0,4,5,8"];-10 [label="1,4,5,7"];-11 [label="1,5,7,8"];-12 [label="0,2,3,4"];-13 [label="0,2,3,8"];-14 [label="0,2,4,7"];-15 [label="0,3,4,6"];-16 [label="2,3,4,8"];-17 [label="0,2,7,8"];-18 [label="0,3,6,8"];-19 [label="0,4,6,7"];-20 [label="2,4,7,8"];-21 [label="2,4,5,6"];-22 [label="2,5,6,8"];-23 [label="0,6,7,8"];-24 [label="3,4,6,8"];-25 [label="4,6,7,8"];-26 [label="1,2,3,7"];-27 [label="1,3,6,7"];-28 [label="2,3,5,7"];-29 [label="3,5,6,7"];-0 -- 1;-0 -- 2;-0 -- 3;-1 -- 21;-1 -- 22;-2 -- 3;-2 -- 21;-3 -- 22;-4 -- 5;-4 -- 6;-4 -- 7;-5 -- 10;-5 -- 11;-6 -- 7;-6 -- 10;-7 -- 11;-8 -- 9;-10 -- 11;-12 -- 13;-12 -- 14;-12 -- 15;-12 -- 16;-13 -- 16;-13 -- 17;-13 -- 18;-14 -- 17;-14 -- 19;-14 -- 20;-15 -- 18;-15 -- 19;-15 -- 24;-16 -- 20;-16 -- 24;-17 -- 20;-17 -- 23;-18 -- 23;-18 -- 24;-19 -- 23;-19 -- 25;-20 -- 25;-21 -- 22;-23 -- 25;-24 -- 25;-26 -- 27;-26 -- 28;-27 -- 29;-28 -- 29;-}
− data/scl/dr_itb_etude_1.scl 
@@ -1,41 +0,0 @@-! dr_itb_etude_1.scl-!-...-36-!-1/1-1/1-1/1-1/1-4/3-16/11-16/11-8/5-8/5-16/9-16/9-2/1-2/1-16/7-16/7-16/7-8/3-8/3-3/1-16/5-16/5-32/9-32/9-4/1-4/1-9/2-9/2-5/1-16/3-11/2-6/1-32/5-32/5-7/1-7/1-8/1
+ data/scl/ew_1357_3.scl view
@@ -0,0 +1,28 @@+! ew_1357_3.scl+!+EW, 1-3-5-7-9Genus.pdf, P.3+23+!+81/80+21/20+35/32+9/8+7/6+189/160+5/4+81/64+21/16+27/20+45/32+35/24+3/2+243/160+63/40+5/3+27/16+7/4+567/320+15/8+35/18+63/32+2/1
+ data/scl/ew_Pelogflute_2.scl view
@@ -0,0 +1,14 @@+! ew_Pelogflute_2.scl+!+EW, Pelogflute.pdf, P.2+9+!+16/15+64/55+5/4+4/3+16/11+8/5+128/75+20/11+2/1
+ data/scl/ew_el12_12.scl view
@@ -0,0 +1,17 @@+! ew_el12_12.scl+!+EW, earlylattices12.pdf, P.12+12+!+45/44+12/11+7/6+5/4+14/11+15/11+35/24+14/9+35/22+56/33+15/8+2/1
+ data/scl/ew_el12_7.scl view
@@ -0,0 +1,17 @@+! ew_el12_7.scl+!+EW, earlylattices12.pdf, P.7+12+!+80/77+8/7+77/64+847/640+11/8+10/7+16/11+847/512+128/77+121/64+77/40+2/1
+ data/scl/ew_hel_12.scl view
@@ -0,0 +1,27 @@+! ew_hel_12.scl+!+EW, hel.pdf, P.12+22+!+135/128+13/12+10/9+9/8+7/6+11/9+5/4+81/64+4/3+11/8+45/32+17/12+3/2+405/256+13/8+5/3+27/16+7/4+11/6+15/8+23/12+2/1
+ data/scl/ew_novarotreediamond_1.scl view
@@ -0,0 +1,28 @@+! ew_novarotreediamond_1.scl+!+EW, novavotreediamond.pdf, P.1+23+!+21/20+16/15+10/9+9/8+8/7+7/6+6/5+5/4+21/16+4/3+7/5+10/7+3/2+32/21+8/5+5/3+12/7+7/4+16/9+9/5+15/8+40/21+2/1
+ data/scl/ew_poole.scl view
@@ -0,0 +1,27 @@+! ew_poole.scl+!+EW, 2010/10/scale-for-rod-poole.html+22+!+33/32+21/20+13/12+9/8+7/6+11/9+5/4+14/11+4/3+11/8+7/5+13/9+3/2+14/9+44/27+5/3+27/16+7/4+11/6+15/8+21/11+2/1
+ data/scl/ew_two_22_7.scl view
@@ -0,0 +1,27 @@+! ew_two_22_7.scl+!+EW, 2018/03/an-unusual-22-tone-7-limit-tuning.html+22+!+36/35+16/15+35/32+9/8+7/6+6/5+315/256+245/192+21/16+27/20+7/5+735/512+189/128+49/32+63/40+5/3+12/7+16/9+64/35+15/8+35/18+2/1
+ data/scl/ew_xen3b_3.scl view
@@ -0,0 +1,22 @@+! ew_xen3b_3.scl+!+EW, xen3b.pdf, P.3+17+!+256/243+12/11+9/8+32/27+5/4+81/64+4/3+1024/729+16/11+3/2+128/81+5/3+27/16+16/9+15/8+243/128+2/1
+ data/scl/ew_xen456_9.scl view
@@ -0,0 +1,24 @@+! ew_xen456_9.scl+!+EW, xen456.pdf, P.9+19+!+45/44+16/15+12/11+8/7+32/27+40/33+14/11+4/3+15/11+64/45+16/11+32/21+8/5+18/11+12/7+16/9+20/11+21/11+2/1
− data/scl/hs17.scl 
@@ -1,22 +0,0 @@-! hs17.scl-!-17 tone harmonic series-17-!-2/1-3/1-4/1-5/1-6/1-7/1-8/1-9/1-10/1-11/1-12/1-13/1-14/1-15/1-16/1-17/1-2/1
− data/scl/hs19.scl 
@@ -1,24 +0,0 @@-! hs19.scl-!-19 tone harmonic series-19-!-2/1-3/1-4/1-5/1-6/1-7/1-8/1-9/1-10/1-11/1-12/1-13/1-14/1-15/1-16/1-17/1-18/1-19/1-2/1
− data/scl/hs21.scl 
@@ -1,26 +0,0 @@-! hs21.scl-!-21 tone harmonic series-21-!-2/1-3/1-4/1-5/1-6/1-7/1-8/1-9/1-10/1-11/1-12/1-13/1-14/1-15/1-16/1-17/1-18/1-19/1-20/1-21/1-2/1
− data/scl/hs23.scl 
@@ -1,28 +0,0 @@-! hs23.scl-!-23 tone harmonic series-23-!-2/1-3/1-4/1-5/1-6/1-7/1-8/1-9/1-10/1-11/1-12/1-13/1-14/1-15/1-16/1-17/1-18/1-19/1-20/1-21/1-22/1-23/1-2/1
hmt.cabal view
@@ -1,27 +1,27 @@ Name:              hmt-Version:           0.16+Version:           0.18 Synopsis:          Haskell Music Theory Description:       Haskell music theory library License:           GPL Category:          Music-Copyright:         Rohan Drape, 2006-2017+Copyright:         Rohan Drape, 2006-2020 Author:            Rohan Drape-Maintainer:        rd@slavepianos.org+Maintainer:        rd@rohandrape.net Stability:         Experimental-Homepage:          http://rd.slavepianos.org/t/hmt-Tested-With:       GHC == 8.0.1+Homepage:          http://rohandrape.net/t/hmt+Tested-With:       GHC == 8.6.5 Build-Type:        Simple-Cabal-Version:     >= 1.8+Cabal-Version:     >= 1.10  Data-files:        README                    data/csv/mnd/*.csv-                   data/dot/*.dot+                   data/dot/euler/*.dot                    data/scl/*.scl  Library   Build-Depends:   aeson,                    array,-                   base >= 4.8 && < 5,+                   base >= 4.9 && < 5,                    bytestring,                    colour,                    containers,@@ -29,24 +29,28 @@                    directory,                    fgl,                    filepath,+                   hsc3 == 0.18.*,                    lazy-csv,                    logict,-                   modular-arithmetic,                    multiset-comb,                    parsec,                    permutation,                    primes,+                   process,                    random,                    safe,                    split,-                   text+                   text,+                   time+  Default-Language:Haskell2010   GHC-Options:     -Wall -fwarn-tabs   Exposed-modules: Music.Theory.Array                    Music.Theory.Array.Cell_Ref                    Music.Theory.Array.CSV                    Music.Theory.Array.CSV.Midi.MND+                   Music.Theory.Array.CSV.Midi.SKINI                    Music.Theory.Array.Direction-                   Music.Theory.Array.MD+                   Music.Theory.Array.Text                    Music.Theory.Bits                    Music.Theory.Bjorklund                    Music.Theory.Block_Design.Johnson_2007@@ -77,7 +81,12 @@                    Music.Theory.Graph.Deacon_1934                    Music.Theory.Graph.Dot                    Music.Theory.Graph.FGL+                   Music.Theory.Graph.IO                    Music.Theory.Graph.Johnson_2014+                   Music.Theory.Graph.LCF+                   Music.Theory.Graph.OBJ+                   Music.Theory.Graph.PLY+                   Music.Theory.Graph.Type                    Music.Theory.Instrument.Choir                    Music.Theory.Instrument.Names                    Music.Theory.Interval@@ -90,19 +99,24 @@                    Music.Theory.Map                    Music.Theory.Math                    Music.Theory.Math.Convert+                   Music.Theory.Math.Convert.FX+                   Music.Theory.Math.Nichomachus                    Music.Theory.Math.OEIS+                   Music.Theory.Math.Prime                    Music.Theory.Maybe                    Music.Theory.Meter.Barlow_1987                    Music.Theory.Metric.Buchler_1998                    Music.Theory.Metric.Morris_1980                    Music.Theory.Metric.Polansky_1996                    Music.Theory.Monad+                   Music.Theory.Opt                    Music.Theory.Ord                    Music.Theory.Parse                    Music.Theory.Permutations                    Music.Theory.Permutations.List                    Music.Theory.Permutations.Morris_1984                    Music.Theory.Pitch+                   Music.Theory.Pitch.Bark                    Music.Theory.Pitch.Chord                    Music.Theory.Pitch.Name                    Music.Theory.Pitch.Note@@ -112,6 +126,7 @@                    Music.Theory.Pitch.Spelling.Key                    Music.Theory.Pitch.Spelling.Table                    Music.Theory.Random.I_Ching+                   Music.Theory.Random.Jones_1981                    Music.Theory.Read                    Music.Theory.Set.List                    Music.Theory.Set.Set@@ -135,11 +150,16 @@                    Music.Theory.Tuning.DB.Microtonal_Synthesis                    Music.Theory.Tuning.DB.Riley                    Music.Theory.Tuning.DB.Werckmeister+                   Music.Theory.Tuning.EFG                    Music.Theory.Tuning.ET-                   Music.Theory.Tuning.Euler                    Music.Theory.Tuning.Gann_1993+                   Music.Theory.Tuning.Graph.Euler+                   Music.Theory.Tuning.Graph.ISET+                   Music.Theory.Tuning.HS                    Music.Theory.Tuning.Load                    Music.Theory.Tuning.Meyer_1929+                   Music.Theory.Tuning.Midi+                   Music.Theory.Tuning.Partch                    Music.Theory.Tuning.Polansky_1978                    Music.Theory.Tuning.Polansky_1984                    Music.Theory.Tuning.Polansky_1985c@@ -147,35 +167,33 @@                    Music.Theory.Tuning.Rosenboom_1979                    Music.Theory.Tuning.Scala                    Music.Theory.Tuning.Scala.Interval+                   Music.Theory.Tuning.Scala.KBM+                   Music.Theory.Tuning.Scala.Meta                    Music.Theory.Tuning.Scala.Mode                    Music.Theory.Tuning.Sethares_1994                    Music.Theory.Tuning.Syntonic+                   Music.Theory.Tuning.Type+                   Music.Theory.Tuning.Wilson                    Music.Theory.Unicode                    Music.Theory.Wyschnegradsky                    Music.Theory.Xenakis.S4                    Music.Theory.Xenakis.Sieve                    Music.Theory.Z                    Music.Theory.Z.Boros_1990+                   Music.Theory.Z.Castren_1994                    Music.Theory.Z.Clough_1979                    Music.Theory.Z.Drape_1999                    Music.Theory.Z.Forte_1973+                   Music.Theory.Z.Lewin_1980+                   Music.Theory.Z.Literature+                   Music.Theory.Z.Morris_1974+                   Music.Theory.Z.Morris_1987+                   Music.Theory.Z.Morris_1987.Parse+                   Music.Theory.Z.Rahn_1980                    Music.Theory.Z.Read_1978                    Music.Theory.Z.TTO                    Music.Theory.Z.SRO-                   Music.Theory.Z12-                   Music.Theory.Z12.Castren_1994-                   Music.Theory.Z12.Drape_1999-                   Music.Theory.Z12.Forte_1973-                   Music.Theory.Z12.Lewin_1980-                   Music.Theory.Z12.Literature-                   Music.Theory.Z12.Morris_1974-                   Music.Theory.Z12.Morris_1987-                   Music.Theory.Z12.Morris_1987.Parse-                   Music.Theory.Z12.Rahn_1980-                   Music.Theory.Z12.Read_1978-                   Music.Theory.Z12.SRO-                   Music.Theory.Z12.TTO  Source-Repository  head   Type:            darcs-  Location:        http://rd.slavepianos.org/sw/hmt+  Location:        http://rohandrape.net/sw/hmt