diff --git a/Music/Theory/Array.hs b/Music/Theory/Array.hs --- a/Music/Theory/Array.hs +++ b/Music/Theory/Array.hs @@ -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 diff --git a/Music/Theory/Array/CSV.hs b/Music/Theory/Array/CSV.hs --- a/Music/Theory/Array/CSV.hs +++ b/Music/Theory/Array/CSV.hs @@ -1,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 diff --git a/Music/Theory/Array/CSV/Midi/MND.hs b/Music/Theory/Array/CSV/Midi/MND.hs --- a/Music/Theory/Array/CSV/Midi/MND.hs +++ b/Music/Theory/Array/CSV/Midi/MND.hs @@ -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 diff --git a/Music/Theory/Array/CSV/Midi/SKINI.hs b/Music/Theory/Array/CSV/Midi/SKINI.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/CSV/Midi/SKINI.hs @@ -0,0 +1,57 @@ +-- | Functions (partial) for reading & writing SKINI data files. +-- +-- +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) diff --git a/Music/Theory/Array/MD.hs b/Music/Theory/Array/MD.hs deleted file mode 100644 --- a/Music/Theory/Array/MD.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Array/Text.hs b/Music/Theory/Array/Text.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Text.hs @@ -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] + +-} diff --git a/Music/Theory/Byte.hs b/Music/Theory/Byte.hs --- a/Music/Theory/Byte.hs +++ b/Music/Theory/Byte.hs @@ -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 + +-} diff --git a/Music/Theory/Combinations.hs b/Music/Theory/Combinations.hs --- a/Music/Theory/Combinations.hs +++ b/Music/Theory/Combinations.hs @@ -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 diff --git a/Music/Theory/DB/Plain.hs b/Music/Theory/DB/Plain.hs --- a/Music/Theory/DB/Plain.hs +++ b/Music/Theory/DB/Plain.hs @@ -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 diff --git a/Music/Theory/Directory.hs b/Music/Theory/Directory.hs --- a/Music/Theory/Directory.hs +++ b/Music/Theory/Directory.hs @@ -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) diff --git a/Music/Theory/Duration.hs b/Music/Theory/Duration.hs --- a/Music/Theory/Duration.hs +++ b/Music/Theory/Duration.hs @@ -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 diff --git a/Music/Theory/Duration/RQ.hs b/Music/Theory/Duration/RQ.hs --- a/Music/Theory/Duration/RQ.hs +++ b/Music/Theory/Duration/RQ.hs @@ -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 + diff --git a/Music/Theory/Dynamic_Mark.hs b/Music/Theory/Dynamic_Mark.hs --- a/Music/Theory/Dynamic_Mark.hs +++ b/Music/Theory/Dynamic_Mark.hs @@ -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 diff --git a/Music/Theory/Either.hs b/Music/Theory/Either.hs --- a/Music/Theory/Either.hs +++ b/Music/Theory/Either.hs @@ -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 diff --git a/Music/Theory/Function.hs b/Music/Theory/Function.hs --- a/Music/Theory/Function.hs +++ b/Music/Theory/Function.hs @@ -1,6 +1,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) diff --git a/Music/Theory/Gamelan.hs b/Music/Theory/Gamelan.hs --- a/Music/Theory/Gamelan.hs +++ b/Music/Theory/Gamelan.hs @@ -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 diff --git a/Music/Theory/Graph/Deacon_1934.hs b/Music/Theory/Graph/Deacon_1934.hs --- a/Music/Theory/Graph/Deacon_1934.hs +++ b/Music/Theory/Graph/Deacon_1934.hs @@ -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))) diff --git a/Music/Theory/Graph/Dot.hs b/Music/Theory/Graph/Dot.hs --- a/Music/Theory/Graph/Dot.hs +++ b/Music/Theory/Graph/Dot.hs @@ -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 + diff --git a/Music/Theory/Graph/FGL.hs b/Music/Theory/Graph/FGL.hs --- a/Music/Theory/Graph/FGL.hs +++ b/Music/Theory/Graph/FGL.hs @@ -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') diff --git a/Music/Theory/Graph/IO.hs b/Music/Theory/Graph/IO.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/IO.hs @@ -0,0 +1,72 @@ +{- | IO for graph files, graph6, sparse6 and digraph6 encodings. + + + +-} +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) diff --git a/Music/Theory/Graph/Johnson_2014.hs b/Music/Theory/Graph/Johnson_2014.hs --- a/Music/Theory/Graph/Johnson_2014.hs +++ b/Music/Theory/Graph/Johnson_2014.hs @@ -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 --- | +-- > 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) diff --git a/Music/Theory/Graph/LCF.hs b/Music/Theory/Graph/LCF.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/LCF.hs @@ -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 + +> 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: diff --git a/Music/Theory/Graph/OBJ.hs b/Music/Theory/Graph/OBJ.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/OBJ.hs @@ -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= +TXT= +-} +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 diff --git a/Music/Theory/Graph/PLY.hs b/Music/Theory/Graph/PLY.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/PLY.hs @@ -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 + +-} +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 diff --git a/Music/Theory/Graph/Type.hs b/Music/Theory/Graph/Type.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Type.hs @@ -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) diff --git a/Music/Theory/Instrument/Choir.hs b/Music/Theory/Instrument/Choir.hs --- a/Music/Theory/Instrument/Choir.hs +++ b/Music/Theory/Instrument/Choir.hs @@ -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) diff --git a/Music/Theory/Interval/Barlow_1987.hs b/Music/Theory/Interval/Barlow_1987.hs --- a/Music/Theory/Interval/Barlow_1987.hs +++ b/Music/Theory/Interval/Barlow_1987.hs @@ -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'] diff --git a/Music/Theory/List.hs b/Music/Theory/List.hs --- a/Music/Theory/List.hs +++ b/Music/Theory/List.hs @@ -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. -- diff --git a/Music/Theory/Math.hs b/Music/Theory/Math.hs --- a/Music/Theory/Math.hs +++ b/Music/Theory/Math.hs @@ -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 + -- | -- -- > integral_and_fractional_parts 1.5 == (1,0.5) @@ -26,7 +39,7 @@ -- | -- -- > 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 @@ -- | -- --- > 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 diff --git a/Music/Theory/Math/Convert.hs b/Music/Theory/Math/Convert.hs --- a/Music/Theory/Math/Convert.hs +++ b/Music/Theory/Math/Convert.hs @@ -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 diff --git a/Music/Theory/Math/Convert/FX.hs b/Music/Theory/Math/Convert/FX.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Convert/FX.hs @@ -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 diff --git a/Music/Theory/Math/Nichomachus.hs b/Music/Theory/Math/Nichomachus.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Nichomachus.hs @@ -0,0 +1,53 @@ +{- | Nichomachus of Gerasa (Νικόμαχος) c.60-c.120 + + +-} +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 diff --git a/Music/Theory/Math/OEIS.hs b/Music/Theory/Math/OEIS.hs --- a/Music/Theory/Math/OEIS.hs +++ b/Music/Theory/Math/OEIS.hs @@ -1,27 +1,470 @@ -- | The On-Line Encyclopedia of Integer Sequences, module Music.Theory.Math.OEIS where --- | --- --- The squares of the non-negative integers. --- --- > import Data.List --- > [0,1,4,9,16,25,36,49,64,81,100] `isInfixOf` a000290 +import Data.List {- base -} +import Data.Ratio {- base -} + +import qualified Music.Theory.Math as Math {- hmt -} + +{- | + +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 ..] + +{- | + +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) + +{- | + +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 + +{- | + +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 + +{- | + +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..] + +{- | + +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) + +{- | + +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..] + +{- | + +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 + +{- | + +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..] +{- | + +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 + +{- | + +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) + +{- | + +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) + +{- | + +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..])) + +{- | + +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)) + +{- | + +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) + +{- | + +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..] + -- | +-- +-- The 15 supersingular primes. a002267 :: Num n => [n] a002267 = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 41, 47, 59, 71] +{- | + +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 + +-- | +-- +-- [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) + +{- | + +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) + +{- | + +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) + +{- | + +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] + + + + +-} +a004718 :: Num n => [n] +a004718 = 0 : concat (transpose [map (+ 1) a004718, map negate (tail a004718)]) + +{- | + +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 ..] + +{- | + +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] + +{- | + +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..]) + +{- | + +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..]) + +{- | + +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] + +{- | + +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 + +{- | + +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] + +{- | + +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) + + +{- | + +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] + +{- | + +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] + +{- | + +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) + +{- | + +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) + +{- | + +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..] + +-- | +-- +-- 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] + +{- | + +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..])) + -- | -- -- 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] -- | -- -- 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] + +-- | +-- +-- 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] + +{- | + +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]) + +{- | + +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)]) + +{- | + +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)]) diff --git a/Music/Theory/Math/Prime.hs b/Music/Theory/Math/Prime.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Prime.hs @@ -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 diff --git a/Music/Theory/Maybe.hs b/Music/Theory/Maybe.hs --- a/Music/Theory/Maybe.hs +++ b/Music/Theory/Maybe.hs @@ -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 diff --git a/Music/Theory/Meter/Barlow_1987.hs b/Music/Theory/Meter/Barlow_1987.hs --- a/Music/Theory/Meter/Barlow_1987.hs +++ b/Music/Theory/Meter/Barlow_1987.hs @@ -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 diff --git a/Music/Theory/Metric/Buchler_1998.hs b/Music/Theory/Metric/Buchler_1998.hs --- a/Music/Theory/Metric/Buchler_1998.hs +++ b/Music/Theory/Metric/Buchler_1998.hs @@ -3,13 +3,14 @@ -- thesis, University of Rochester, 1998 module Music.Theory.Metric.Buchler_1998 where +import Data.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) diff --git a/Music/Theory/Metric/Morris_1980.hs b/Music/Theory/Metric/Morris_1980.hs --- a/Music/Theory/Metric/Morris_1980.hs +++ b/Music/Theory/Metric/Morris_1980.hs @@ -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') diff --git a/Music/Theory/Metric/Polansky_1996.hs b/Music/Theory/Metric/Polansky_1996.hs --- a/Music/Theory/Metric/Polansky_1996.hs +++ b/Music/Theory/Metric/Polansky_1996.hs @@ -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 diff --git a/Music/Theory/Monad.hs b/Music/Theory/Monad.hs --- a/Music/Theory/Monad.hs +++ b/Music/Theory/Monad.hs @@ -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 diff --git a/Music/Theory/Opt.hs b/Music/Theory/Opt.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Opt.hs @@ -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) diff --git a/Music/Theory/Ord.hs b/Music/Theory/Ord.hs --- a/Music/Theory/Ord.hs +++ b/Music/Theory/Ord.hs @@ -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 diff --git a/Music/Theory/Parse.hs b/Music/Theory/Parse.hs --- a/Music/Theory/Parse.hs +++ b/Music/Theory/Parse.hs @@ -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 diff --git a/Music/Theory/Permutations.hs b/Music/Theory/Permutations.hs --- a/Music/Theory/Permutations.hs +++ b/Music/Theory/Permutations.hs @@ -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"] -} diff --git a/Music/Theory/Permutations/List.hs b/Music/Theory/Permutations/List.hs --- a/Music/Theory/Permutations/List.hs +++ b/Music/Theory/Permutations/List.hs @@ -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)) diff --git a/Music/Theory/Permutations/Morris_1984.hs b/Music/Theory/Permutations/Morris_1984.hs --- a/Music/Theory/Permutations/Morris_1984.hs +++ b/Music/Theory/Permutations/Morris_1984.hs @@ -5,7 +5,6 @@ -- module Music.Theory.Permutations.Morris_1984 where -import Data.Char {- base -} import Data.List {- base -} import Data.List.Split {- split -} import Data.Maybe {- base -} diff --git a/Music/Theory/Pitch.hs b/Music/Theory/Pitch.hs --- a/Music/Theory/Pitch.hs +++ b/Music/Theory/Pitch.hs @@ -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 -- --- > 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 diff --git a/Music/Theory/Pitch/Bark.hs b/Music/Theory/Pitch/Bark.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Bark.hs @@ -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) +-- +-- +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) diff --git a/Music/Theory/Pitch/Chord.hs b/Music/Theory/Pitch/Chord.hs --- a/Music/Theory/Pitch/Chord.hs +++ b/Music/Theory/Pitch/Chord.hs @@ -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 diff --git a/Music/Theory/Pitch/Note.hs b/Music/Theory/Pitch/Note.hs --- a/Music/Theory/Pitch/Note.hs +++ b/Music/Theory/Pitch/Note.hs @@ -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 and -- -- -- > map alteration_tonh [Flat .. Sharp] == ["es","eh","","ih","is"] alteration_tonh :: Alteration_T -> String -alteration_tonh a = - case a of - DoubleFlat -> "eses" - ThreeQuarterToneFlat -> "eseh" - Flat -> "es" - QuarterToneFlat -> "eh" - Natural -> "" - QuarterToneSharp -> "ih" - Sharp -> "is" - ThreeQuarterToneSharp -> "isih" - DoubleSharp -> "isis" +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) diff --git a/Music/Theory/Pitch/Spelling.hs b/Music/Theory/Pitch/Spelling.hs --- a/Music/Theory/Pitch/Spelling.hs +++ b/Music/Theory/Pitch/Spelling.hs @@ -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 diff --git a/Music/Theory/Pitch/Spelling/Cluster.hs b/Music/Theory/Pitch/Spelling/Cluster.hs --- a/Music/Theory/Pitch/Spelling/Cluster.hs +++ b/Music/Theory/Pitch/Spelling/Cluster.hs @@ -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 diff --git a/Music/Theory/Pitch/Spelling/Table.hs b/Music/Theory/Pitch/Spelling/Table.hs --- a/Music/Theory/Pitch/Spelling/Table.hs +++ b/Music/Theory/Pitch/Spelling/Table.hs @@ -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 diff --git a/Music/Theory/Random/I_Ching.hs b/Music/Theory/Random/I_Ching.hs --- a/Music/Theory/Random/I_Ching.hs +++ b/Music/Theory/Random/I_Ching.hs @@ -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",'牛')] diff --git a/Music/Theory/Random/Jones_1981.hs b/Music/Theory/Random/Jones_1981.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Random/Jones_1981.hs @@ -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 diff --git a/Music/Theory/Read.hs b/Music/Theory/Read.hs --- a/Music/Theory/Read.hs +++ b/Music/Theory/Read.hs @@ -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 + diff --git a/Music/Theory/Set/List.hs b/Music/Theory/Set/List.hs --- a/Music/Theory/Set/List.hs +++ b/Music/Theory/Set/List.hs @@ -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. -- diff --git a/Music/Theory/Show.hs b/Music/Theory/Show.hs --- a/Music/Theory/Show.hs +++ b/Music/Theory/Show.hs @@ -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 "") diff --git a/Music/Theory/String.hs b/Music/Theory/String.hs --- a/Music/Theory/String.hs +++ b/Music/Theory/String.hs @@ -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) diff --git a/Music/Theory/Time/Bel1990/R.hs b/Music/Theory/Time/Bel1990/R.hs --- a/Music/Theory/Time/Bel1990/R.hs +++ b/Music/Theory/Time/Bel1990/R.hs @@ -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 diff --git a/Music/Theory/Time/Notation.hs b/Music/Theory/Time/Notation.hs --- a/Music/Theory/Time/Notation.hs +++ b/Music/Theory/Time/Notation.hs @@ -1,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 diff --git a/Music/Theory/Time/Seq.hs b/Music/Theory/Time/Seq.hs --- a/Music/Theory/Time/Seq.hs +++ b/Music/Theory/Time/Seq.hs @@ -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 diff --git a/Music/Theory/Tuning.hs b/Music/Theory/Tuning.hs --- a/Music/Theory/Tuning.hs +++ b/Music/Theory/Tuning.hs @@ -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 ("","") --- * 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 - --- | 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)) diff --git a/Music/Theory/Tuning/Alves_1997.hs b/Music/Theory/Tuning/Alves_1997.hs --- a/Music/Theory/Tuning/Alves_1997.hs +++ b/Music/Theory/Tuning/Alves_1997.hs @@ -3,54 +3,58 @@ -- 1997. 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 diff --git a/Music/Theory/Tuning/DB.hs b/Music/Theory/Tuning/DB.hs --- a/Music/Theory/Tuning/DB.hs +++ b/Music/Theory/Tuning/DB.hs @@ -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) + +-} + diff --git a/Music/Theory/Tuning/DB/Alves.hs b/Music/Theory/Tuning/DB/Alves.hs --- a/Music/Theory/Tuning/DB/Alves.hs +++ b/Music/Theory/Tuning/DB/Alves.hs @@ -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 +-- | Ditone/pythagorean tuning, -- -- > 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 diff --git a/Music/Theory/Tuning/DB/Gann.hs b/Music/Theory/Tuning/DB/Gann.hs --- a/Music/Theory/Tuning/DB/Gann.hs +++ b/Music/Theory/Tuning/DB/Gann.hs @@ -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 -- -- --- > 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, . -- --- > 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 . -- --- > 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 -- -- --- > 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 . -- -- > 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 . -- --- > 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 diff --git a/Music/Theory/Tuning/DB/Microtonal_Synthesis.hs b/Music/Theory/Tuning/DB/Microtonal_Synthesis.hs --- a/Music/Theory/Tuning/DB/Microtonal_Synthesis.hs +++ b/Music/Theory/Tuning/DB/Microtonal_Synthesis.hs @@ -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 diff --git a/Music/Theory/Tuning/DB/Riley.hs b/Music/Theory/Tuning/DB/Riley.hs --- a/Music/Theory/Tuning/DB/Riley.hs +++ b/Music/Theory/Tuning/DB/Riley.hs @@ -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 diff --git a/Music/Theory/Tuning/DB/Werckmeister.hs b/Music/Theory/Tuning/DB/Werckmeister.hs --- a/Music/Theory/Tuning/DB/Werckmeister.hs +++ b/Music/Theory/Tuning/DB/Werckmeister.hs @@ -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 diff --git a/Music/Theory/Tuning/EFG.hs b/Music/Theory/Tuning/EFG.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/EFG.hs @@ -0,0 +1,111 @@ +-- | Euler-Fokker genus +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 ..]) diff --git a/Music/Theory/Tuning/ET.hs b/Music/Theory/Tuning/ET.hs --- a/Music/Theory/Tuning/ET.hs +++ b/Music/Theory/Tuning/ET.hs @@ -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 diff --git a/Music/Theory/Tuning/Euler.hs b/Music/Theory/Tuning/Euler.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Euler.hs +++ /dev/null @@ -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) - --} diff --git a/Music/Theory/Tuning/Gann_1993.hs b/Music/Theory/Tuning/Gann_1993.hs --- a/Music/Theory/Tuning/Gann_1993.hs +++ b/Music/Theory/Tuning/Gann_1993.hs @@ -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'. diff --git a/Music/Theory/Tuning/Graph/Euler.hs b/Music/Theory/Tuning/Graph/Euler.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Graph/Euler.hs @@ -0,0 +1,124 @@ +-- | Euler plane diagrams as /dot/ language graphs. +-- +-- +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) diff --git a/Music/Theory/Tuning/Graph/ISET.hs b/Music/Theory/Tuning/Graph/ISET.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Graph/ISET.hs @@ -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 +-} diff --git a/Music/Theory/Tuning/HS.hs b/Music/Theory/Tuning/HS.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/HS.hs @@ -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 + diff --git a/Music/Theory/Tuning/Load.hs b/Music/Theory/Tuning/Load.hs --- a/Music/Theory/Tuning/Load.hs +++ b/Music/Theory/Tuning/Load.hs @@ -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) diff --git a/Music/Theory/Tuning/Meyer_1929.hs b/Music/Theory/Tuning/Meyer_1929.hs --- a/Music/Theory/Tuning/Meyer_1929.hs +++ b/Music/Theory/Tuning/Meyer_1929.hs @@ -95,13 +95,17 @@ degree :: Integral i => i -> i degree = genericLength . elements --- | --- --- > let r = [[0,1/2,1] --- > ,[0,1/3,1/2,2/3,1] --- > ,[0,1/4,1/3,1/2,2/3,3/4,1] --- > ,[0,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,1] --- > ,[0,1/6,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,5/6,1]] --- > in map farey_sequence [2..6] == r +{- | + +> 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]]) diff --git a/Music/Theory/Tuning/Midi.hs b/Music/Theory/Tuning/Midi.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Midi.hs @@ -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 diff --git a/Music/Theory/Tuning/Partch.hs b/Music/Theory/Tuning/Partch.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Partch.hs @@ -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 + + ---- ----- ----- ---- ---- ---- ----- ----- ----- ----- + +-} diff --git a/Music/Theory/Tuning/Polansky_1978.hs b/Music/Theory/Tuning/Polansky_1978.hs --- a/Music/Theory/Tuning/Polansky_1978.hs +++ b/Music/Theory/Tuning/Polansky_1978.hs @@ -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 diff --git a/Music/Theory/Tuning/Polansky_1985c.hs b/Music/Theory/Tuning/Polansky_1985c.hs --- a/Music/Theory/Tuning/Polansky_1985c.hs +++ b/Music/Theory/Tuning/Polansky_1985c.hs @@ -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)) diff --git a/Music/Theory/Tuning/Rosenboom_1979.hs b/Music/Theory/Tuning/Rosenboom_1979.hs --- a/Music/Theory/Tuning/Rosenboom_1979.hs +++ b/Music/Theory/Tuning/Rosenboom_1979.hs @@ -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) diff --git a/Music/Theory/Tuning/Scala.hs b/Music/Theory/Tuning/Scala.hs --- a/Music/Theory/Tuning/Scala.hs +++ b/Music/Theory/Tuning/Scala.hs @@ -1,7 +1,10 @@ --- | Parser for the Scala scale file format. See --- for details. --- This module succesfully parses all 4671 scales in v.85 of the scale --- library. +{- | Parser for the Scala scale file format. + +See 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] +-- | +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 diff --git a/Music/Theory/Tuning/Scala/Interval.hs b/Music/Theory/Tuning/Scala/Interval.hs --- a/Music/Theory/Tuning/Scala/Interval.hs +++ b/Music/Theory/Tuning/Scala/Interval.hs @@ -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)) diff --git a/Music/Theory/Tuning/Scala/KBM.hs b/Music/Theory/Tuning/Scala/KBM.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/KBM.hs @@ -0,0 +1,132 @@ +{- | Scala "keyboard mapping" files (.kbm) and related data structure. + + +-} +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]) diff --git a/Music/Theory/Tuning/Scala/Meta.hs b/Music/Theory/Tuning/Scala/Meta.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Meta.hs @@ -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 +-} diff --git a/Music/Theory/Tuning/Scala/Mode.hs b/Music/Theory/Tuning/Scala/Mode.hs --- a/Music/Theory/Tuning/Scala/Mode.hs +++ b/Music/Theory/Tuning/Scala/Mode.hs @@ -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))) diff --git a/Music/Theory/Tuning/Sethares_1994.hs b/Music/Theory/Tuning/Sethares_1994.hs --- a/Music/Theory/Tuning/Sethares_1994.hs +++ b/Music/Theory/Tuning/Sethares_1994.hs @@ -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) diff --git a/Music/Theory/Tuning/Syntonic.hs b/Music/Theory/Tuning/Syntonic.hs --- a/Music/Theory/Tuning/Syntonic.hs +++ b/Music/Theory/Tuning/Syntonic.hs @@ -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 diff --git a/Music/Theory/Tuning/Type.hs b/Music/Theory/Tuning/Type.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Type.hs @@ -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) + diff --git a/Music/Theory/Tuning/Wilson.hs b/Music/Theory/Tuning/Wilson.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Wilson.hs @@ -0,0 +1,903 @@ +-- | Erv Wilson, archives +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] +-- +-- +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] +-- +-- +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 +-- +-- +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])) + +-- * + +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) + +-- * + +{- | 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 + +-- * + +{- | 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] + +-- * + +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] + +-- * + +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 + +-- * + +-- > 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))) + +-- * + +-- > 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 + +-- * + +{- | 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] + +-- * (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 + +-- * + +{- | 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 + + +-- * + +-- | 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) + +-- * + +-- | 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 + +-- * + +{- | 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 + +-- * + +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 + +{- | + +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 + +{- | + +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] + +{- | + +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: diff --git a/Music/Theory/Tuple.hs b/Music/Theory/Tuple.hs --- a/Music/Theory/Tuple.hs +++ b/Music/Theory/Tuple.hs @@ -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: diff --git a/Music/Theory/Unicode.hs b/Music/Theory/Unicode.hs --- a/Music/Theory/Unicode.hs +++ b/Music/Theory/Unicode.hs @@ -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] +{- | +> 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 --- | +-- | 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")] diff --git a/Music/Theory/Xenakis/S4.hs b/Music/Theory/Xenakis/S4.hs --- a/Music/Theory/Xenakis/S4.hs +++ b/Music/Theory/Xenakis/S4.hs @@ -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) diff --git a/Music/Theory/Z.hs b/Music/Theory/Z.hs --- a/Music/Theory/Z.hs +++ b/Music/Theory/Z.hs @@ -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 diff --git a/Music/Theory/Z/Boros_1990.hs b/Music/Theory/Z/Boros_1990.hs --- a/Music/Theory/Z/Boros_1990.hs +++ b/Music/Theory/Z/Boros_1990.hs @@ -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' diff --git a/Music/Theory/Z/Castren_1994.hs b/Music/Theory/Z/Castren_1994.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Castren_1994.hs @@ -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 diff --git a/Music/Theory/Z/Clough_1979.hs b/Music/Theory/Z/Clough_1979.hs --- a/Music/Theory/Z/Clough_1979.hs +++ b/Music/Theory/Z/Clough_1979.hs @@ -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 diff --git a/Music/Theory/Z/Drape_1999.hs b/Music/Theory/Z/Drape_1999.hs --- a/Music/Theory/Z/Drape_1999.hs +++ b/Music/Theory/Z/Drape_1999.hs @@ -1,18 +1,367 @@ +-- | Haskell implementations of @pct@ operations. +-- See 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) diff --git a/Music/Theory/Z/Forte_1973.hs b/Music/Theory/Z/Forte_1973.hs --- a/Music/Theory/Z/Forte_1973.hs +++ b/Music/Theory/Z/Forte_1973.hs @@ -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 diff --git a/Music/Theory/Z/Lewin_1980.hs b/Music/Theory/Z/Lewin_1980.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Lewin_1980.hs @@ -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 diff --git a/Music/Theory/Z/Literature.hs b/Music/Theory/Z/Literature.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Literature.hs @@ -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.") ] diff --git a/Music/Theory/Z/Morris_1974.hs b/Music/Theory/Z/Morris_1974.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Morris_1974.hs @@ -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 diff --git a/Music/Theory/Z/Morris_1987.hs b/Music/Theory/Z/Morris_1987.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Morris_1987.hs @@ -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) diff --git a/Music/Theory/Z/Morris_1987/Parse.hs b/Music/Theory/Z/Morris_1987/Parse.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Morris_1987/Parse.hs @@ -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'' diff --git a/Music/Theory/Z/Rahn_1980.hs b/Music/Theory/Z/Rahn_1980.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Rahn_1980.hs @@ -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 + ] diff --git a/Music/Theory/Z/Read_1978.hs b/Music/Theory/Z/Read_1978.hs --- a/Music/Theory/Z/Read_1978.hs +++ b/Music/Theory/Z/Read_1978.hs @@ -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)) diff --git a/Music/Theory/Z/SRO.hs b/Music/Theory/Z/SRO.hs --- a/Music/Theory/Z/SRO.hs +++ b/Music/Theory/Z/SRO.hs @@ -2,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)) diff --git a/Music/Theory/Z/TTO.hs b/Music/Theory/Z/TTO.hs --- a/Music/Theory/Z/TTO.hs +++ b/Music/Theory/Z/TTO.hs @@ -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 diff --git a/Music/Theory/Z12.hs b/Music/Theory/Z12.hs deleted file mode 100644 --- a/Music/Theory/Z12.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/Castren_1994.hs b/Music/Theory/Z12/Castren_1994.hs deleted file mode 100644 --- a/Music/Theory/Z12/Castren_1994.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/Drape_1999.hs b/Music/Theory/Z12/Drape_1999.hs deleted file mode 100644 --- a/Music/Theory/Z12/Drape_1999.hs +++ /dev/null @@ -1,588 +0,0 @@ --- | Haskell implementations of @pct@ operations. --- See . -module Music.Theory.Z12.Drape_1999 where - -import Data.Function {- base -} -import Data.List {- base -} -import Data.Maybe {- base -} -import 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) diff --git a/Music/Theory/Z12/Forte_1973.hs b/Music/Theory/Z12/Forte_1973.hs deleted file mode 100644 --- a/Music/Theory/Z12/Forte_1973.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/Lewin_1980.hs b/Music/Theory/Z12/Lewin_1980.hs deleted file mode 100644 --- a/Music/Theory/Z12/Lewin_1980.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/Literature.hs b/Music/Theory/Z12/Literature.hs deleted file mode 100644 --- a/Music/Theory/Z12/Literature.hs +++ /dev/null @@ -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.") ] diff --git a/Music/Theory/Z12/Morris_1974.hs b/Music/Theory/Z12/Morris_1974.hs deleted file mode 100644 --- a/Music/Theory/Z12/Morris_1974.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/Morris_1987.hs b/Music/Theory/Z12/Morris_1987.hs deleted file mode 100644 --- a/Music/Theory/Z12/Morris_1987.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/Morris_1987/Parse.hs b/Music/Theory/Z12/Morris_1987/Parse.hs deleted file mode 100644 --- a/Music/Theory/Z12/Morris_1987/Parse.hs +++ /dev/null @@ -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'' diff --git a/Music/Theory/Z12/Rahn_1980.hs b/Music/Theory/Z12/Rahn_1980.hs deleted file mode 100644 --- a/Music/Theory/Z12/Rahn_1980.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/Read_1978.hs b/Music/Theory/Z12/Read_1978.hs deleted file mode 100644 --- a/Music/Theory/Z12/Read_1978.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/SRO.hs b/Music/Theory/Z12/SRO.hs deleted file mode 100644 --- a/Music/Theory/Z12/SRO.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Z12/TTO.hs b/Music/Theory/Z12/TTO.hs deleted file mode 100644 --- a/Music/Theory/Z12/TTO.hs +++ /dev/null @@ -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)) diff --git a/README b/README --- a/README +++ b/README @@ -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/). diff --git a/data/csv/mnd/all-notes-off.csv b/data/csv/mnd/all-notes-off.csv new file mode 100644 --- /dev/null +++ b/data/csv/mnd/all-notes-off.csv @@ -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, diff --git a/data/dot/euler-j5-a.dot b/data/dot/euler-j5-a.dot deleted file mode 100644 --- a/data/dot/euler-j5-a.dot +++ /dev/null @@ -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} -} diff --git a/data/dot/euler-j5-b.dot b/data/dot/euler-j5-b.dot deleted file mode 100644 --- a/data/dot/euler-j5-b.dot +++ /dev/null @@ -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} -} diff --git a/data/dot/euler-j7.dot b/data/dot/euler-j7.dot deleted file mode 100644 --- a/data/dot/euler-j7.dot +++ /dev/null @@ -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} -} diff --git a/data/dot/euler-wtp.dot b/data/dot/euler-wtp.dot deleted file mode 100644 --- a/data/dot/euler-wtp.dot +++ /dev/null @@ -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} -} diff --git a/data/dot/euler/euler-j5-a.dot b/data/dot/euler/euler-j5-a.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-j5-a.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_3 [label="A♮\n5:3"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_16_9 [label="B♭\n16:9"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_64_45 [label="F♯\n64:45"]; +R_16_15 [label="C♯\n16:15"]; +R_8_5 [label="A♭\n8:5"]; +R_6_5 [label="E♭\n6:5"]; +R_5_3 -- R_5_4 -- R_15_8; +R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8; +R_64_45 -- R_16_15 -- R_8_5 -- R_6_5; +R_4_3 -- R_5_3 [label=" (8:5)"]; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_64_45 -- R_16_9 [label=" (8:5)"]; +R_16_15 -- R_4_3 [label=" (8:5)"]; +R_8_5 -- R_1_1 [label=" (8:5)"]; +R_6_5 -- R_3_2 [label=" (8:5)"]; +{rank=min; R_5_3 R_5_4 R_15_8} +{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8} +{rank=max; R_64_45 R_16_15 R_8_5 R_6_5} +} diff --git a/data/dot/euler/euler-j5-b.dot b/data/dot/euler/euler-j5-b.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-j5-b.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_3 [label="A♮\n5:3"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_45_32 [label="F♯\n45:32"]; +R_16_9 [label="B♭\n16:9"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_16_15 [label="C♯\n16:15"]; +R_8_5 [label="A♭\n8:5"]; +R_6_5 [label="E♭\n6:5"]; +R_5_3 -- R_5_4 -- R_15_8 -- R_45_32; +R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8; +R_16_15 -- R_8_5 -- R_6_5; +R_4_3 -- R_5_3 [label=" (8:5)"]; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_9_8 -- R_45_32 [label=" (8:5)"]; +R_16_15 -- R_4_3 [label=" (8:5)"]; +R_8_5 -- R_1_1 [label=" (8:5)"]; +R_6_5 -- R_3_2 [label=" (8:5)"]; +{rank=min; R_5_3 R_5_4 R_15_8 R_45_32} +{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8} +{rank=max; R_16_15 R_8_5 R_6_5} +} diff --git a/data/dot/euler/euler-j7.dot b/data/dot/euler/euler-j7.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-j7.dot @@ -0,0 +1,29 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_45_32 [label="F♯\n45:32"]; +R_135_128 [label="C♯\n135:128"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_27_16 [label="A♮\n27:16"]; +R_14_9 [label="A♭\n14:9"]; +R_7_6 [label="E♭\n7:6"]; +R_7_4 [label="B♭\n7:4"]; +R_5_4 -- R_15_8 -- R_45_32 -- R_135_128; +R_4_3 -- R_1_1 -- R_3_2 -- R_9_8 -- R_27_16; +R_14_9 -- R_7_6 -- R_7_4; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_9_8 -- R_45_32 [label=" (8:5)"]; +R_27_16 -- R_135_128 [label=" (8:5)"]; +R_7_6 -- R_4_3 [label=" (7:4)"]; +R_7_4 -- R_1_1 [label=" (7:4)"]; +{rank=min; R_5_4 R_15_8 R_45_32 R_135_128} +{rank=same; R_4_3 R_1_1 R_3_2 R_9_8 R_27_16} +{rank=max; R_14_9 R_7_6 R_7_4} +} diff --git a/data/dot/euler/euler-wtp.dot b/data/dot/euler/euler-wtp.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-wtp.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_49_32 [label="B♭=738\n49:32"]; +R_147_128 [label="F♮=240\n147:128"]; +R_441_256 [label="C♮=942\n441:256"]; +R_1323_1024 [label="G♮=444\n1323:1024"]; +R_7_4 [label="C♯=969\n7:4"]; +R_21_16 [label="A♭=471\n21:16"]; +R_63_32 [label="E♭=1173\n63:32"]; +R_189_128 [label="B♭=675\n189:128"]; +R_567_512 [label="F♮=177\n567:512"]; +R_1_1 [label="E♭=0\n1:1"]; +R_3_2 [label="B♭=702\n3:2"]; +R_9_8 [label="F♮=204\n9:8"]; +R_49_32 -- R_147_128 -- R_441_256 -- R_1323_1024; +R_7_4 -- R_21_16 -- R_63_32 -- R_189_128 -- R_567_512; +R_1_1 -- R_3_2 -- R_9_8; +R_7_4 -- R_49_32 [label=" (8:7)"]; +R_21_16 -- R_147_128 [label=" (8:7)"]; +R_63_32 -- R_441_256 [label=" (8:7)"]; +R_189_128 -- R_1323_1024 [label=" (8:7)"]; +R_1_1 -- R_7_4 [label=" (8:7)"]; +R_3_2 -- R_21_16 [label=" (8:7)"]; +R_9_8 -- R_63_32 [label=" (8:7)"]; +{rank=min; R_49_32 R_147_128 R_441_256 R_1323_1024} +{rank=same; R_7_4 R_21_16 R_63_32 R_189_128 R_567_512} +{rank=max; R_1_1 R_3_2 R_9_8} +} diff --git a/data/dot/tj_oh_p012.dot b/data/dot/tj_oh_p012.dot deleted file mode 100644 --- a/data/dot/tj_oh_p012.dot +++ /dev/null @@ -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} -} diff --git a/data/dot/tj_oh_p014.dot b/data/dot/tj_oh_p014.dot deleted file mode 100644 --- a/data/dot/tj_oh_p014.dot +++ /dev/null @@ -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; -} diff --git a/data/dot/tj_oh_p031.dot b/data/dot/tj_oh_p031.dot deleted file mode 100644 --- a/data/dot/tj_oh_p031.dot +++ /dev/null @@ -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; -} diff --git a/data/dot/tj_oh_p125.dot b/data/dot/tj_oh_p125.dot deleted file mode 100644 --- a/data/dot/tj_oh_p125.dot +++ /dev/null @@ -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; -} diff --git a/data/dot/tj_oh_p131.dot b/data/dot/tj_oh_p131.dot deleted file mode 100644 --- a/data/dot/tj_oh_p131.dot +++ /dev/null @@ -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; -} diff --git a/data/dot/tj_oh_p162.dot b/data/dot/tj_oh_p162.dot deleted file mode 100644 --- a/data/dot/tj_oh_p162.dot +++ /dev/null @@ -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; -} diff --git a/data/scl/dr_itb_etude_1.scl b/data/scl/dr_itb_etude_1.scl deleted file mode 100644 --- a/data/scl/dr_itb_etude_1.scl +++ /dev/null @@ -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 diff --git a/data/scl/ew_1357_3.scl b/data/scl/ew_1357_3.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_1357_3.scl @@ -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 diff --git a/data/scl/ew_Pelogflute_2.scl b/data/scl/ew_Pelogflute_2.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_Pelogflute_2.scl @@ -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 diff --git a/data/scl/ew_el12_12.scl b/data/scl/ew_el12_12.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_el12_12.scl @@ -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 diff --git a/data/scl/ew_el12_7.scl b/data/scl/ew_el12_7.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_el12_7.scl @@ -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 diff --git a/data/scl/ew_hel_12.scl b/data/scl/ew_hel_12.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_hel_12.scl @@ -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 diff --git a/data/scl/ew_novarotreediamond_1.scl b/data/scl/ew_novarotreediamond_1.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_novarotreediamond_1.scl @@ -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 diff --git a/data/scl/ew_poole.scl b/data/scl/ew_poole.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_poole.scl @@ -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 diff --git a/data/scl/ew_two_22_7.scl b/data/scl/ew_two_22_7.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_two_22_7.scl @@ -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 diff --git a/data/scl/ew_xen3b_3.scl b/data/scl/ew_xen3b_3.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_xen3b_3.scl @@ -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 diff --git a/data/scl/ew_xen456_9.scl b/data/scl/ew_xen456_9.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_xen456_9.scl @@ -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 diff --git a/data/scl/hs17.scl b/data/scl/hs17.scl deleted file mode 100644 --- a/data/scl/hs17.scl +++ /dev/null @@ -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 diff --git a/data/scl/hs19.scl b/data/scl/hs19.scl deleted file mode 100644 --- a/data/scl/hs19.scl +++ /dev/null @@ -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 diff --git a/data/scl/hs21.scl b/data/scl/hs21.scl deleted file mode 100644 --- a/data/scl/hs21.scl +++ /dev/null @@ -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 diff --git a/data/scl/hs23.scl b/data/scl/hs23.scl deleted file mode 100644 --- a/data/scl/hs23.scl +++ /dev/null @@ -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 diff --git a/hmt.cabal b/hmt.cabal --- a/hmt.cabal +++ b/hmt.cabal @@ -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