packages feed

hmt 0.18 → 0.20

raw patch · 166 files changed

+9783/−13660 lines, 166 filesdep +data-memocombinatorsdep +hmt-basedep +strictdep −aesondep −hsc3dep −permutation

Dependencies added: data-memocombinators, hmt-base, strict

Dependencies removed: aeson, hsc3, permutation

Files

− Music/Theory/Array.hs 
@@ -1,119 +0,0 @@--- | Array & table functions-module Music.Theory.Array where--import Data.List {- base -}-import qualified Data.Array as A {- array -}--import qualified Music.Theory.List as T {- hmt -}---- * Association List (List Array)---- | '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).-tbl_make_regular_nil :: t -> Table t -> Table t-tbl_make_regular_nil k = tbl_make_regular (id,k)---- * Matrix Indices---- | Matrix dimensions are written (rows,columns).-type Dimensions i = (i,i)---- | Matrix indices are written (row,column) & are here _zero_ indexed.-type Ix i = (i,i)---- | Translate 'Ix' by row and column delta.------ > ix_translate (1,2) (3,4) == (4,6)-ix_translate :: Num t => (t,t) -> Ix t -> Ix t-ix_translate (dr,dc) (r,c) = (r + dr,c + dc)---- | Modulo 'Ix' by 'Dimensions'.------ > ix_modulo (4,4) (3,7) == (3,3)-ix_modulo :: Integral t => Dimensions t -> Ix t -> Ix t-ix_modulo (nr,nc) (r,c) = (r `mod` nr,c `mod` nc)---- | Given number of columns and row index, list row indices.------ > row_indices 3 1 == [(1,0),(1,1),(1,2)]-row_indices :: (Enum t, Num t) => t -> t -> [Ix t]-row_indices nc r = map (\c -> (r,c)) [0 .. nc - 1]---- | Given number of rows and column index, list column indices.------ > column_indices 3 1 == [(0,1),(1,1),(2,1)]-column_indices :: (Enum t, Num t) => t -> t -> [Ix t]-column_indices nr c = map (\r -> (r,c)) [0 .. nr - 1]---- | All zero-indexed matrix indices, in row order.  This is the order--- given by 'sort'.------ > matrix_indices (2,3) == [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2)]--- > sort (matrix_indices (2,3)) == matrix_indices (2,3)-matrix_indices :: (Enum t, Num t) => Dimensions t -> [Ix t]-matrix_indices (nr,nc) = concatMap (row_indices nc) [0 .. nr - 1 ]---- | Corner indices of given 'Dimensions', in row order.------ > matrix_corner_indices (2,3) == [(0,0),(0,2),(1,0),(1,2)]-matrix_corner_indices :: Num t => Dimensions t -> [Ix t]-matrix_corner_indices (nr,nc) = [(0,0),(0,nc - 1),(nr - 1,0),(nr - 1,nc - 1)]---- | Parallelogram corner indices, given as rectangular 'Dimensions' with an--- offset for the lower indices.------ > parallelogram_corner_indices ((2,3),2) == [(0,0),(0,2),(1,2),(1,4)]-parallelogram_corner_indices :: Num t => (Dimensions t,t) -> [Ix t]-parallelogram_corner_indices ((nr,nc),o) = [(0,0),(0,nc - 1),(nr - 1,o),(nr - 1,nc + o - 1)]---- | Apply 'ix_modulo' and 'ix_translate' for all 'matrix_indices',--- ie. all translations of a 'shape' in row order.  The resulting 'Ix'--- sets are not sorted and may have duplicates.------ > concat (all_ix_translations (2,3) [(0,0)]) == matrix_indices (2,3)-all_ix_translations :: Integral t => Dimensions t -> [Ix t] -> [[Ix t]]-all_ix_translations dm ix =-    let f z = ix_modulo dm . ix_translate z-    in map (\dx -> map (f dx) ix) (matrix_indices dm)---- | Sort sets into row order and remove duplicates.-all_ix_translations_uniq :: Integral t => Dimensions t -> [Ix t] -> [[Ix t]]-all_ix_translations_uniq dm = nub . map sort . all_ix_translations dm
− Music/Theory/Array/CSV.hs 
@@ -1,222 +0,0 @@--- | Regular matrix array data, CSV, column & row indexing.-module Music.Theory.Array.CSV where--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 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?-type CSV_Has_Header = Bool---- | Alias for 'Char', allow characters other than @,@ as delimiter.-type CSV_Delimiter = Char---- | Alias for 'Bool', allow linebreaks in fields.-type CSV_Allow_Linebreaks = Bool---- | When writing a CSV file should the delimiters be aligned,--- ie. should columns be padded with spaces, and if so at which side--- of the data?-data CSV_Align_Columns = CSV_No_Align | CSV_Align_Left | CSV_Align_Right---- | CSV options.-type CSV_Opt = (CSV_Has_Header,CSV_Delimiter,CSV_Allow_Linebreaks,CSV_Align_Columns)---- | Default CSV options, no header, comma delimiter, no linebreaks, no alignment.-def_csv_opt :: CSV_Opt-def_csv_opt = (False,',',False,CSV_No_Align)---- | CSV table, ie. a 'Table' with 'Maybe' a header.-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)-csv_table_read (hdr,delim,brk,_) f fn = do-  s <- T.read_file_utf8 fn-  let t = C.csvTable (C.parseDSV brk delim s)-      p = C.fromCSVTable t-      (h,d) = if hdr then (Just (head p),tail p) else (Nothing,p)-  return (h,map (map f) d)---- | Read '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)---- | 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 -> T.Table String -> T.Table String-csv_table_align align tbl =-    let c = transpose tbl-        n = map (maximum . map length) c-        ext k s = let pd = replicate (k - length s) ' '-                  in case align of-                       CSV_No_Align -> s-                       CSV_Align_Left -> pd ++ s-                       CSV_Align_Right -> s ++ pd-    in transpose (zipWith (map . ext) n c)---- | Pretty-print 'CSV_Table'.-csv_table_pp :: (a -> String) -> CSV_Opt -> CSV_Table a -> String-csv_table_pp f (_,delim,brk,align) (hdr,tbl) =-  let tbl' = csv_table_align align (T.mcons hdr (map (map f) tbl))-      (_,t) = C.toCSVTable tbl'-  in C.ppDSVTable brk delim t---- | 'T.write_file_utf8' of 'csv_table_pp'.-csv_table_write :: (a -> String) -> CSV_Opt -> FilePath -> CSV_Table a -> IO ()-csv_table_write f 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 -> 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 :: 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 :: T.Table a -> R.Row_Ref -> [a]-table_row t r = Safe.atNote "table_row" t (R.row_index r)---- | Column data.-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 => 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 :: T.Table a -> R.Cell_Ref -> a-table_cell t (c,r) =-    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 :: T.Table a -> (Int,(Int,Int)) -> [a]-table_lookup_row_segment t (r,(c0,c1)) =-    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 :: T.Table a -> (R.Row_Ref,R.Column_Range) -> [a]-table_row_segment t (r,c) =-    let (r',c') = (R.row_index r,R.column_indices c)-    in table_lookup_row_segment t (r',c')---- * Array---- | Translate 'Table' to 'Array'.  It is assumed that the 'Table' is--- regular, ie. all rows have an equal number of columns.------ > let a = table_to_array [[0,1,3],[2,4,5]]--- > in (bounds a,indices a,elems a)------ > > (((A,1),(C,2))--- > > ,[(A,1),(A,2),(B,1),(B,2),(C,1),(C,2)]--- > > ,[0,2,1,4,3,5])-table_to_array :: T.Table a -> A.Array R.Cell_Ref a-table_to_array t =-    let nr = length 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 R.Cell_Ref a)-csv_array_read opt f fn = fmap (table_to_array . snd) (csv_table_read opt f fn)---- * Irregular--csv_field_str :: C.CSVField -> String-csv_field_str f =-    case f of-      C.CSVField _ _ _ _ s _ -> s-      C.CSVFieldError _ _ _ _ _ -> error "csv_field_str"--csv_error_recover :: C.CSVError -> C.CSVRow-csv_error_recover e =-    case e of-      C.IncorrectRow _ _ _ f -> f-      C.BlankLine _ _ _ _ -> []-      _ -> error "csv_error_recover: not recoverable"--csv_row_recover :: Either [C.CSVError] C.CSVRow -> C.CSVRow-csv_row_recover r =-    case r of-      Left [e] -> csv_error_recover e-      Left _ -> error "csv_row_recover: multiple errors"-      Right r' -> r'---- | Read irregular @CSV@ file, ie. rows may have any number of columns, including no columns.-csv_load_irregular :: (String -> a) -> FilePath -> IO [[a]]-csv_load_irregular f fn = do-  s <- T.read_file_utf8 fn-  return (map (map (f . csv_field_str) . csv_row_recover) (C.parseCSV s))--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--type P5_Parser t1 t2 t3 t4 t5 = (String -> t1,String -> t2,String -> t3,String -> t4,String -> t5)-type P5_Writer t1 t2 t3 t4 t5 = (t1 -> String,t2 -> String,t3 -> String,t4 -> String,t5 -> String)--csv_table_read_p5 :: P5_Parser t1 t2 t3 t4 t5 -> CSV_Opt -> FilePath -> IO (Maybe [String],[(t1,t2,t3,t4,t5)])-csv_table_read_p5 f opt fn = do-  (hdr,dat) <- csv_table_read opt id fn-  return (hdr,map (T.p5_from_list f) dat)--csv_table_write_p5 :: P5_Writer t1 t2 t3 t4 t5 -> CSV_Opt -> FilePath -> (Maybe [String],[(t1,t2,t3,t4,t5)]) -> IO ()-csv_table_write_p5 f opt fn (hdr,dat) = csv_table_write id opt fn (hdr,map (T.p5_to_list f) dat)
− Music/Theory/Array/CSV/Midi/MND.hs 
@@ -1,241 +0,0 @@--- | Functions for reading midi note data (MND) from CSV files.--- This is /not/ a generic text midi notation.--- The defined commands are @on@ and @off@, but others may be present.--- Non-integral note number and key velocity data are allowed.-module Music.Theory.Array.CSV.Midi.MND where--import Data.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.-data_value_pp :: Real t => Int -> t -> String-data_value_pp k r =-    if T.whole_to_precision k r-    then show (T.real_floor_int r)-    else T.real_pp k r---- | Channel values are 4-bit (0-15).-type Channel = Word8---- | The required header field.-csv_mnd_hdr :: [String]-csv_mnd_hdr = ["time","on/off","note","velocity","channel","param"]---- | 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"------ > 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_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-                    ,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)-                _ -> 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"--- > 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---- | Writer.-csv_mnd_write :: (Real t,Real n) => Int -> FilePath -> [MND t n] -> IO ()-csv_mnd_write r_prec nm =-    let un_node (st,msg,mnn,vel,ch,pm) =-            [T.real_pp r_prec st-            ,msg-            ,data_value_pp r_prec mnn-            ,data_value_pp r_prec vel-            ,show ch-            ,param_pp (';','=') r_prec pm]-        with_hdr dat = (Just csv_mnd_hdr,dat)-    in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node---- * MND Seq forms---- | (p0=midi-note,p1=velocity,channel,param)-type Event n = (n,n,Channel,Param)---- | 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)--midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t x -> T.Tseq t (T.Begin_End x)-midi_wseq_to_midi_tseq = T.wseq_begin_end---- | Ignores non on/off messages.-mnd_to_tseq :: Num n => [MND t n] -> T.Tseq t (T.Begin_End (Event n))-mnd_to_tseq =-    let mk_node (st,msg,mnn,vel,ch,pm) =-            case msg of-              "on" -> Just (st,T.Begin (mnn,vel,ch,pm))-              "off" -> Just (st,T.End (mnn,0,ch,pm))-              _ -> Nothing-    in mapMaybe mk_node---- | 'Tseq' form of 'csv_mnd_read', channel information is retained, off-velocity is zero.-csv_mnd_read_tseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.Begin_End (Event n)))-csv_mnd_read_tseq = fmap mnd_to_tseq . csv_mnd_read---- | 'Tseq' form of 'csv_mnd_write', data is .-csv_mnd_write_tseq :: (Real t,Real n) => Int -> FilePath -> T.Tseq t (T.Begin_End (Event n)) -> IO ()-csv_mnd_write_tseq r_prec nm sq =-    let f (t,e) = case e of-                    T.Begin (n,v,c,p) -> (t,"on",n,v,c,p)-                    T.End (n,_,c,p) -> (t,"off",n,0,c,p)-    in csv_mnd_write r_prec nm (map f sq)---- * MNDD (simplifies cases where overlaps on the same channel are allowed).---- | Message should be @note@ for note data.-csv_mndd_hdr :: [String]-csv_mndd_hdr = ["time","duration","message","note","velocity","channel","param"]---- | 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)---- | 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-              [st,du,msg,mnn,vel,ch,pm] ->-                  (T.reads_exact_err "time" st-                  ,T.reads_exact_err "duration" du-                  ,msg-                  ,cnv (T.reads_exact_err "note" mnn)-                  ,cnv (T.reads_exact_err "velocity" vel)-                  ,T.reads_exact_err "channel" ch-                  ,param_parse (';','=') pm)-              _ -> err "entry?"-    in case hdr of-         Just hdr' -> if hdr' == csv_mndd_hdr then map f dat else err "header?"-         Nothing -> err "no header?"---- | 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---- | Writer.-csv_mndd_write :: (Real t,Real n) => Int -> FilePath -> [MNDD t n] -> IO ()-csv_mndd_write r_prec nm =-    let un_node (st,du,msg,mnn,vel,ch,pm) =-            [T.real_pp r_prec st,T.real_pp r_prec du,msg-            ,data_value_pp r_prec mnn,data_value_pp r_prec vel-            ,show ch-            ,param_pp (';','=') r_prec pm]-        with_hdr dat = (Just csv_mndd_hdr,dat)-    in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node---- * MNDD Seq forms---- | Ignores non note messages.-mndd_to_wseq :: [MNDD t n] -> T.Wseq t (Event n)-mndd_to_wseq =-    let mk_node (st,du,msg,mnn,vel,ch,pm) =-            case msg of-              "note" -> Just ((st,du),(mnn,vel,ch,pm))-              _ -> Nothing-    in mapMaybe mk_node---- | 'Wseq' form of 'csv_mndd_read'.-csv_mndd_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))-csv_mndd_read_wseq = fmap mndd_to_wseq . csv_mndd_read---- | 'Wseq' form of 'csv_mndd_write'.-csv_mndd_write_wseq :: (Real t,Real n) => Int -> FilePath -> T.Wseq t (Event n) -> IO ()-csv_mndd_write_wseq r_prec nm =-    let f ((st,du),(mnn,vel,ch,pm)) = (st,du,"note",mnn,vel,ch,pm)-    in csv_mndd_write r_prec nm . map f---- * Composite---- | Parse either MND or MNDD data to Wseq, CSV type is decided by header.-csv_midi_parse_wseq_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_f cnv (hdr,dat)))-                 else if hdr' == csv_mndd_hdr-                      then mndd_to_wseq (csv_mndd_parse_f cnv (hdr,dat))-                      else error "csv_midi_read_wseq: not MND or MNDD"-    _ -> error "csv_midi_read_wseq: header?"--csv_midi_parse_wseq :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> T.Wseq t (Event n)-csv_midi_parse_wseq = csv_midi_parse_wseq_f id--csv_midi_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))-csv_midi_read_wseq = fmap csv_midi_parse_wseq . load_csv
− Music/Theory/Array/CSV/Midi/SKINI.hs 
@@ -1,57 +0,0 @@--- | Functions (partial) for reading & writing SKINI data files.------ <https://ccrma.stanford.edu/software/stk/skini.html>-module Music.Theory.Array.CSV.Midi.SKINI where--import Data.List {- base -}--import qualified Music.Theory.Array.CSV.Midi.MND as T {- hmt -}-import qualified Music.Theory.Time.Seq as T {- hmt -}---- | SKINI allows delta or absolute time-stamps.-data TIME t = Delta t | Absolute t---- | SKINI data type of (message,time-stamp,channel,data-one,data-two)-type SKINI t n = (String,TIME t,T.Channel,n,n)--mnd_msg_to_skini_msg :: String -> String-mnd_msg_to_skini_msg msg =-  case msg of-    "on" -> "NoteOn"-    "off" -> "NoteOff"-    _ -> error "mnd_msg_to_skini_msg"--mnd_to_skini_f :: (t -> TIME t) -> T.MND t n -> SKINI t n-mnd_to_skini_f f mnd =-  case mnd of-    (t,msg,d1,d2,ch,[]) -> (mnd_msg_to_skini_msg msg,f t,ch,d1,d2)-    _ -> error "mnd_to_skini"--mnd_to_skini_abs :: T.MND t n -> SKINI t n-mnd_to_skini_abs = mnd_to_skini_f Absolute--midi_tseq_to_skini_seq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (T.Event n)) -> [SKINI t n]-midi_tseq_to_skini_seq =-  let f e =-        case e of-          (t,(T.Begin (d1,d2,ch,[]))) -> ("NoteOn",Delta t,ch,d1,d2)-          (t,(T.End (d1,d2,ch,[]))) -> ("NoteOff",Delta t,ch,d1,d2)-          _ -> error "midi_tseq_to_skini_seq"-  in map f . T.tseq_to_iseq--time_pp :: Real t => Int -> TIME t -> String-time_pp k t =-  case t of-    Delta x -> T.data_value_pp k x-    Absolute x -> '=' : T.data_value_pp k x--skini_pp_csv :: (Real t,Real n) => Int -> SKINI t n -> String-skini_pp_csv k (msg,t,ch,d1,d2) =-  let f = T.data_value_pp k-  in intercalate "," [msg,time_pp k t,show ch,f d1,f d2]---- > let fn = "/home/rohan/sw/hmt/data/csv/mnd/1080-C01.csv"--- > m <- T.csv_mnd_read_tseq fn :: IO (T.Tseq Double (T.Begin_End (T.Event Int)))--- > skini_write_csv 4 "/tmp/t.skini" (midi_tseq_to_skini_seq m)-skini_write_csv :: (Real t,Real n) => Int -> FilePath -> [SKINI t n] -> IO ()-skini_write_csv k fn = writeFile fn . unlines . map (skini_pp_csv k)
− Music/Theory/Array/Cell_Ref.hs 
@@ -1,228 +0,0 @@--- | Cell references & indexing.-module Music.Theory.Array.Cell_Ref where--import qualified Data.Array as A {- array -}-import Data.Char {- base -}-import Data.Function {- base -}-import Data.Maybe {- base -}-import Data.String {- base -}---- | @A@ indexed case-insensitive column references.  The column--- following @Z@ is @AA@.-data Column_Ref = Column_Ref {column_ref_string :: String}--instance IsString Column_Ref where fromString = Column_Ref-instance Read Column_Ref where readsPrec _ s = [(Column_Ref s,[])]-instance Show Column_Ref where show = column_ref_string-instance Eq Column_Ref where (==) = (==) `on` column_index-instance Ord Column_Ref where compare = compare `on` column_index--instance Enum Column_Ref where-    fromEnum = column_index-    toEnum = column_ref--instance A.Ix Column_Ref where-    range = column_range-    index = interior_column_index-    inRange = column_in_range-    rangeSize = column_range_size---- | Inclusive range of column references.-type Column_Range = (Column_Ref,Column_Ref)---- | @1@-indexed row reference.-type Row_Ref = Int---- | Zero index of 'Row_Ref'.-row_index :: Row_Ref -> Int-row_index r = r - 1---- | Inclusive range of row references.-type Row_Range = (Row_Ref,Row_Ref)---- | Cell reference, column then row.-type Cell_Ref = (Column_Ref,Row_Ref)---- | Inclusive range of cell references.-type Cell_Range = (Cell_Ref,Cell_Ref)---- | Case folding letter to index function.  Only valid for ASCII letters.------ > map letter_index ['A' .. 'Z'] == [0 .. 25]--- > map letter_index ['a','d' .. 'm'] == [0,3 .. 12]-letter_index :: Char -> Int-letter_index c = fromEnum (toUpper c) - fromEnum 'A'---- | Inverse of 'letter_index'.------ > map index_letter [0,3 .. 12] == ['A','D' .. 'M']-index_letter :: Int -> Char-index_letter i = toEnum (i + fromEnum 'A')---- | Translate column reference to @0@-index.------ > :set -XOverloadedStrings--- > map column_index ["A","c","z","ac","XYZ"] == [0,2,25,28,17575]-column_index :: Column_Ref -> Int-column_index (Column_Ref c) =-    let m = iterate (* 26) 1-        i = reverse (map letter_index c)-    in sum (zipWith (*) m (zipWith (+) [0..] i))---- | Column reference to interior index within specified range.  Type--- specialised 'Data.Ix.index'.------ > map (Data.Ix.index ('A','Z')) ['A','C','Z'] == [0,2,25]--- > map (interior_column_index ("A","Z")) ["A","C","Z"] == [0,2,25]------ > map (Data.Ix.index ('B','C')) ['B','C'] == [0,1]--- > map (interior_column_index ("B","C")) ["B","C"] == [0,1]-interior_column_index :: Column_Range -> Column_Ref -> Int-interior_column_index (l,r) c =-    let n = column_index c-        l' = column_index l-        r' = column_index r-    in if n > r'-       then error (show ("interior_column_index",l,r,c))-       else n - l'---- | Inverse of 'column_index'.------ > let c = ["A","Z","AA","AZ","BA","BZ","CA"]--- > in map column_ref [0,25,26,51,52,77,78] == c------ > column_ref (0+25+1+25+1+25+1) == "CA"-column_ref :: Int -> Column_Ref-column_ref =-    let rec n = case n `quotRem` 26 of-                  (0,r) -> [index_letter r]-                  (q,r) -> index_letter (q - 1) : rec r-    in Column_Ref . rec---- | Type specialised 'pred'.------ > column_ref_pred "DF" == "DE"-column_ref_pred :: Column_Ref -> Column_Ref-column_ref_pred = pred---- | Type specialised 'succ'.------ > column_ref_succ "DE" == "DF"-column_ref_succ :: Column_Ref -> Column_Ref-column_ref_succ = succ---- | Bimap of 'column_index'.------ > column_indices ("b","p") == (1,15)--- > column_indices ("B","IT") == (1,253)-column_indices :: Column_Range -> (Int,Int)-column_indices =-    let bimap f (i,j) = (f i,f j)-    in bimap column_index---- | Type specialised 'Data.Ix.range'.------ > column_range ("L","R") == ["L","M","N","O","P","Q","R"]--- > Data.Ix.range ('L','R') == "LMNOPQR"-column_range :: Column_Range -> [Column_Ref]-column_range rng =-    let (l,r) = column_indices rng-    in map column_ref [l .. r]---- | Type specialised 'Data.Ix.inRange'.------ > map (column_in_range ("L","R")) ["A","N","Z"] == [False,True,False]--- > map (column_in_range ("L","R")) ["L","N","R"] == [True,True,True]------ > map (Data.Ix.inRange ('L','R')) ['A','N','Z'] == [False,True,False]--- > map (Data.Ix.inRange ('L','R')) ['L','N','R'] == [True,True,True]-column_in_range :: Column_Range -> Column_Ref -> Bool-column_in_range rng c =-    let (l,r) = column_indices rng-        k = column_index c-    in k >= l && k <= r---- | Type specialised 'Data.Ix.rangeSize'.------ > map column_range_size [("A","Z"),("AA","ZZ")] == [26,26 * 26]--- > Data.Ix.rangeSize ('A','Z') == 26-column_range_size :: Column_Range -> Int-column_range_size = (+ 1) . negate . uncurry (-) . column_indices---- | Type specialised 'Data.Ix.range'.-row_range :: Row_Range -> [Row_Ref]-row_range = A.range---- | The standard uppermost leftmost cell reference, @A1@.------ > Just cell_ref_minima == parse_cell_ref "A1"-cell_ref_minima :: Cell_Ref-cell_ref_minima = (Column_Ref "A",1)---- | Cell reference parser for standard notation of (column,row).------ > parse_cell_ref "CC348" == Just ("CC",348)-parse_cell_ref :: String -> Maybe Cell_Ref-parse_cell_ref s =-    case span isUpper s of-      ([],_) -> Nothing-      (c,r) -> case span isDigit r of-                 (n,[]) -> Just (Column_Ref c,read n)-                 _ -> Nothing--is_cell_ref :: String -> Bool-is_cell_ref = isJust . parse_cell_ref--parse_cell_ref_err :: String -> Cell_Ref-parse_cell_ref_err = fromMaybe (error "parse_cell_ref") . parse_cell_ref---- | Cell reference pretty printer.------ > cell_ref_pp ("CC",348) == "CC348"-cell_ref_pp :: Cell_Ref -> String-cell_ref_pp (Column_Ref c,r) = c ++ show r---- | Translate cell reference to @0@-indexed pair.------ > cell_index ("CC",348) == (80,347)--- > Data.Ix.index (("AA",1),("ZZ",999)) ("CC",348) == 54293-cell_index :: Cell_Ref -> (Int,Int)-cell_index (c,r) = (column_index c,row_index r)---- | Inverse of cell_index.------ > index_to_cell (80,347) == (Column_Ref "CC",348)--- > index_to_cell (4,5) == (Column_Ref "E",6)-index_to_cell :: (Int,Int) -> Cell_Ref-index_to_cell (c,r) = (column_ref c,r + 1)--parse_cell_index :: String -> (Int,Int)-parse_cell_index = cell_index . parse_cell_ref_err---- | Type specialised 'Data.Ix.range', cells are in column-order.------ > cell_range (("AA",1),("AC",1)) == [("AA",1),("AB",1),("AC",1)]------ > let r = [("AA",1),("AA",2),("AB",1),("AB",2),("AC",1),("AC",2)]--- > in cell_range (("AA",1),("AC",2)) == r------ > Data.Ix.range (('A',1),('C',1)) == [('A',1),('B',1),('C',1)]------ > let r = [('A',1),('A',2),('B',1),('B',2),('C',1),('C',2)]--- > in Data.Ix.range (('A',1),('C',2)) == r-cell_range :: Cell_Range -> [Cell_Ref]-cell_range ((c1,r1),(c2,r2)) =-    [(c,r) |-     c <- column_range (c1,c2)-    ,r <- row_range (r1,r2)]---- | Variant of 'cell_range' in row-order.------ > let r = [(AA,1),(AB,1),(AC,1),(AA,2),(AB,2),(AC,2)]--- > in cell_range_row_order (("AA",1),("AC",2)) == r-cell_range_row_order ::  Cell_Range -> [Cell_Ref]-cell_range_row_order ((c1,r1),(c2,r2)) =-    [(c,r) |-     r <- row_range (r1,r2)-    ,c <- column_range (c1,c2)]-
+ Music/Theory/Array/Csv/Midi/Cli.hs view
@@ -0,0 +1,47 @@+module Music.Theory.Array.Csv.Midi.Cli where++import qualified Music.Theory.Array.Csv.Midi.Mnd as T {- hmt -}+import qualified Music.Theory.Time.Seq as T {- hmt -}++usage :: [String]+usage =+  ["concat {r} -o output-file input-file..."+  ,"mnd-to-mndd {i|r} precision:int input-file output-file"+  ,"mndd-transpose precision:int n:int input-file output-file"]++read_wseq_i :: FilePath -> IO (T.Wseq Double (T.Event Int))+read_wseq_i = T.csv_midi_read_wseq++read_wseq_r :: FilePath -> IO (T.Wseq Double (T.Event Double))+read_wseq_r = T.csv_midi_read_wseq++mnd_to_mndd_i :: Int -> FilePath -> FilePath -> IO ()+mnd_to_mndd_i p i_fn o_fn = do+  m <- read_wseq_i i_fn+  T.csv_mndd_write_wseq p o_fn m++mndd_transpose_r :: Int -> Double -> FilePath -> FilePath -> IO ()+mndd_transpose_r p k i_fn o_fn = do+  m <- read_wseq_r i_fn+  let f (t,(mnn,vel,ch,pr)) = (t,(mnn + k,vel,ch,pr))+  T.csv_mndd_write_wseq p o_fn (map f m)++csv_midi_concat_r :: FilePath -> [FilePath] -> IO ()+csv_midi_concat_r o_fn i_fn = do+  i <- mapM read_wseq_r i_fn+  T.csv_mndd_write_wseq 4 o_fn (T.wseq_concat i)++csv_midi_cli :: [String] -> IO ()+csv_midi_cli arg =+  case arg of+    "concat":"r":"-o":o_fn:i_fn -> csv_midi_concat_r o_fn i_fn+    ["mnd-to-mndd","i",p,i_fn,o_fn] -> mnd_to_mndd_i (read p) i_fn o_fn+    ["mndd-transpose","r",p,k,i_fn,o_fn] -> mndd_transpose_r (read p) (read k) i_fn o_fn+    _ -> putStrLn (unlines usage)++{-+fn = "/home/rohan/uc/invisible/heliotrope/csv/rough/00.csv"+mnd_to_mndd_i 4 fn "/tmp/t-mndd.csv"+mndd_transpose_r 4 (-12) fn "/tmp/t-trs.csv"+-}+
+ Music/Theory/Array/Csv/Midi/Mnd.hs view
@@ -0,0 +1,270 @@+{- | Functions for reading midi note data (Mnd) from Csv files.++This is /not/ a generic text midi notation.+The required columns are documented at `Mnd` and `Mndd`.+The defined commands are @on@ and @off@, but others may be present.+Non-integral note number and key velocity data are allowed.+-}+module Music.Theory.Array.Csv.Midi.Mnd where++import Data.Function {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import Data.List.Split {- split -}++import qualified Music.Theory.Array.Csv as T {- hmt-base -}+import qualified Music.Theory.Math as T {- hmt-base -}+import qualified Music.Theory.Read as T {- hmt-base -}+import qualified Music.Theory.Show as T {- hmt-base -}++import qualified Music.Theory.Time.Seq as T {- hmt -}++-- * Param ; Sound.SC3.Server.Param++type Param = [(String,Double)]++param_parse :: (Char,Char) -> String -> Param+param_parse (c1,c2) str =+    let f x = case splitOn [c2] x of+                [lhs,rhs] -> (lhs,read rhs)+                _ -> error ("param_parse: " ++ x)+    in if null str then [] else map f (splitOn [c1] str)++param_pp :: (Char,Char) -> Int -> Param -> String+param_pp (c1,c2) k =+    let f (lhs,rhs) = concat [lhs,[c2],T.double_pp k rhs]+    in intercalate [c1] . map f++-- * Mnd++-- | If /r/ is whole to /k/ places then show as integer, else as float to /k/ places.+data_value_pp :: Real t => Int -> t -> String+data_value_pp k r =+    if T.whole_to_precision k r+    then show (T.real_floor_int r)+    else T.real_pp k r++-- | Channel values are 4-bit (0-15).+type Channel = Int++-- | The required header (column names) field.+csv_mnd_hdr :: [String]+csv_mnd_hdr = ["time","on/off","note","velocity","channel","param"]++{- | 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.+note and velocity data is (0-127), channel is (0-15), param are ;-separated key:string=value:float.++> unwords csv_mnd_hdr == "time on/off note velocity 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_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+                    ,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)+                _ -> 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"+-- > 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++-- | Writer.+csv_mnd_write :: (Real t,Real n) => Int -> FilePath -> [Mnd t n] -> IO ()+csv_mnd_write r_prec nm =+    let un_node (st,msg,mnn,vel,ch,pm) =+            [T.real_pp r_prec st+            ,msg+            ,data_value_pp r_prec mnn+            ,data_value_pp r_prec vel+            ,show ch+            ,param_pp (';','=') r_prec pm]+        with_hdr dat = (Just csv_mnd_hdr,dat)+    in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node++-- * Mnd Seq forms++-- | (p0=midi-note,p1=velocity,channel,param)+type Event n = (n,n,Channel,Param)++-- | 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 field?+event_eq_mnn :: Eq t => Event t -> Event t -> Bool+event_eq_mnn = (==) `on` event_mnn++-- | 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)++midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t x -> T.Tseq t (T.Begin_End x)+midi_wseq_to_midi_tseq = T.wseq_begin_end++-- | Ignores non on/off messages.+mnd_to_tseq :: Num n => [Mnd t n] -> T.Tseq t (T.Begin_End (Event n))+mnd_to_tseq =+    let mk_node (st,msg,mnn,vel,ch,pm) =+            case msg of+              "on" -> Just (st,T.Begin (mnn,vel,ch,pm))+              "off" -> Just (st,T.End (mnn,0,ch,pm))+              _ -> Nothing+    in mapMaybe mk_node++-- | 'Tseq' form of 'csv_mnd_read', channel information is retained, off-velocity is zero.+csv_mnd_read_tseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.Begin_End (Event n)))+csv_mnd_read_tseq = fmap mnd_to_tseq . csv_mnd_read++-- | 'Tseq' form of 'csv_mnd_write', data is .+csv_mnd_write_tseq :: (Real t,Real n) => Int -> FilePath -> T.Tseq t (T.Begin_End (Event n)) -> IO ()+csv_mnd_write_tseq r_prec nm sq =+    let f (t,e) = case e of+                    T.Begin (n,v,c,p) -> (t,"on",n,v,c,p)+                    T.End (n,_,c,p) -> (t,"off",n,0,c,p)+    in csv_mnd_write r_prec nm (map f sq)++-- * Mndd (simplifies cases where overlaps on the same channel are allowed).++-- | Message should be @note@ for note data.+csv_mndd_hdr :: [String]+csv_mndd_hdr = ["time","duration","message","note","velocity","channel","param"]++-- | 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)++-- | 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+              [st,du,msg,mnn,vel,ch,pm] ->+                  (T.reads_exact_err "time" st+                  ,T.reads_exact_err "duration" du+                  ,msg+                  ,cnv (T.reads_exact_err "note" mnn)+                  ,cnv (T.reads_exact_err "velocity" vel)+                  ,T.reads_exact_err "channel" ch+                  ,param_parse (';','=') pm)+              _ -> err "entry?"+    in case hdr of+         Just hdr' -> if hdr' == csv_mndd_hdr then map f dat else err "header?"+         Nothing -> err "no header?"++-- | 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++-- | Writer.+csv_mndd_write :: (Real t,Real n) => Int -> FilePath -> [Mndd t n] -> IO ()+csv_mndd_write r_prec nm =+    let un_node (st,du,msg,mnn,vel,ch,pm) =+            [T.real_pp r_prec st,T.real_pp r_prec du,msg+            ,data_value_pp r_prec mnn,data_value_pp r_prec vel+            ,show ch+            ,param_pp (';','=') r_prec pm]+        with_hdr dat = (Just csv_mndd_hdr,dat)+    in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node++-- * Mndd Seq forms++-- | Ignores non note messages.+mndd_to_wseq :: [Mndd t n] -> T.Wseq t (Event n)+mndd_to_wseq =+    let mk_node (st,du,msg,mnn,vel,ch,pm) =+            case msg of+              "note" -> Just ((st,du),(mnn,vel,ch,pm))+              _ -> Nothing+    in mapMaybe mk_node++-- | 'Wseq' form of 'csv_mndd_read'.+csv_mndd_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))+csv_mndd_read_wseq = fmap mndd_to_wseq . csv_mndd_read++-- | 'Wseq' form of 'csv_mndd_write'.+csv_mndd_write_wseq :: (Real t,Real n) => Int -> FilePath -> T.Wseq t (Event n) -> IO ()+csv_mndd_write_wseq r_prec nm =+    let f ((st,du),(mnn,vel,ch,pm)) = (st,du,"note",mnn,vel,ch,pm)+    in csv_mndd_write r_prec nm . map f++-- * Composite++-- | Parse either Mnd or Mndd data to Wseq, Csv type is decided by header.+csv_midi_parse_wseq_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_f cnv (hdr,dat)))+                 else if hdr' == csv_mndd_hdr+                      then mndd_to_wseq (csv_mndd_parse_f cnv (hdr,dat))+                      else error "csv_midi_read_wseq: not Mnd or Mndd"+    _ -> error "csv_midi_read_wseq: header?"++csv_midi_parse_wseq :: (Read t,Real t,Read n,Real n) => T.Csv_Table String -> T.Wseq t (Event n)+csv_midi_parse_wseq = csv_midi_parse_wseq_f id++csv_midi_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))+csv_midi_read_wseq = fmap csv_midi_parse_wseq . load_csv
+ Music/Theory/Array/Csv/Midi/Skini.hs view
@@ -0,0 +1,57 @@+-- | Functions (partial) for reading & writing Skini data files.+--+-- <https://ccrma.stanford.edu/software/stk/skini.html>+module Music.Theory.Array.Csv.Midi.Skini where++import Data.List {- base -}++import qualified Music.Theory.Array.Csv.Midi.Mnd as T {- hmt -}+import qualified Music.Theory.Time.Seq as T {- hmt -}++-- | Skini allows delta or absolute time-stamps.+data Time t = Delta t | Absolute t++-- | Skini data type of (message,time-stamp,channel,data-one,data-two)+type Skini t n = (String,Time t,T.Channel,n,n)++mnd_msg_to_skini_msg :: String -> String+mnd_msg_to_skini_msg msg =+  case msg of+    "on" -> "NoteOn"+    "off" -> "NoteOff"+    _ -> error "mnd_msg_to_skini_msg"++mnd_to_skini_f :: (t -> Time t) -> T.Mnd t n -> Skini t n+mnd_to_skini_f f mnd =+  case mnd of+    (t,msg,d1,d2,ch,[]) -> (mnd_msg_to_skini_msg msg,f t,ch,d1,d2)+    _ -> error "mnd_to_skini"++mnd_to_skini_abs :: T.Mnd t n -> Skini t n+mnd_to_skini_abs = mnd_to_skini_f Absolute++midi_tseq_to_skini_seq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (T.Event n)) -> [Skini t n]+midi_tseq_to_skini_seq =+  let f e =+        case e of+          (t,T.Begin (d1,d2,ch,[])) -> ("NoteOn",Delta t,ch,d1,d2)+          (t,T.End (d1,d2,ch,[])) -> ("NoteOff",Delta t,ch,d1,d2)+          _ -> error "midi_tseq_to_skini_seq"+  in map f . T.tseq_to_iseq++time_pp :: Real t => Int -> Time t -> String+time_pp k t =+  case t of+    Delta x -> T.data_value_pp k x+    Absolute x -> '=' : T.data_value_pp k x++skini_pp_csv :: (Real t,Real n) => Int -> Skini t n -> String+skini_pp_csv k (msg,t,ch,d1,d2) =+  let f = T.data_value_pp k+  in intercalate "," [msg,time_pp k t,show ch,f d1,f d2]++-- > let fn = "/home/rohan/sw/hmt/data/csv/mnd/1080-C01.csv"+-- > m <- T.csv_mnd_read_tseq fn :: IO (T.Tseq Double (T.Begin_End (T.Event Int)))+-- > skini_write_csv 4 "/tmp/t.skini" (midi_tseq_to_skini_seq m)+skini_write_csv :: (Real t,Real n) => Int -> FilePath -> [Skini t n] -> IO ()+skini_write_csv k fn = writeFile fn . unlines . map (skini_pp_csv k)
Music/Theory/Array/Direction.hs view
@@ -41,7 +41,7 @@ derive_vec (c1,r1) (c2,r2) = (c2 - c1,r2 - r1)  unfold_path :: Num n => LOC n -> [VEC n] -> [LOC n]-unfold_path l p = scanl apply_vec l p+unfold_path = scanl apply_vec  -- * DIRECTION (non-diagonal)
+ Music/Theory/Array/Square.hs view
@@ -0,0 +1,198 @@+-- | Square arrays, where the number of rows and columns are equal.+module Music.Theory.Array.Square where++import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Data.Map as Map {- containers -}+import qualified Data.List.Split as Split {- split -}++import qualified Music.Theory.Array as T {- hmt-base -}+import qualified Music.Theory.Array.Text as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}++import qualified Music.Theory.Math.Oeis as T {- hmt -}++-- | Square as list of lists.+type Square t = [[t]]++-- | Squares are functors+sq_map :: (t -> t) -> Square t -> Square t+sq_map f = map (map f)++-- | 'sq_map' of '*' /n/+sq_scale :: Num t => t -> Square t -> Square t+sq_scale n = sq_map (* n)++-- | /f/ pointwise at two squares (of equal size, un-checked)+sq_zip :: (t -> t -> t) -> Square t -> Square t -> Square t+sq_zip f = zipWith (zipWith f)++-- | 'sq_zip' of '*'+sq_mul :: Num t => Square t -> Square t -> Square t+sq_mul = sq_zip (*)++-- | 'sq_zip' of '+'+sq_add :: Num t => Square t -> Square t -> Square t+sq_add = sq_zip (+)++-- | 'foldl1' of 'sq_add'+sq_sum :: Num t => [Square t] -> Square t+sq_sum = foldl1 sq_add++-- | Predicate to determine if 'Square' is actually square.+sq_is_square :: Square t -> Bool+sq_is_square sq = nub (map length sq) == [length sq]++-- | Square as row order list+type Square_Linear t = [t]++-- | Given degree of square, form 'Square' from 'Square_Linear'.+sq_from_list :: Int -> Square_Linear t -> Square t+sq_from_list = Split.chunksOf++-- | True if list can form a square, ie. if 'length' is a square.+--+-- > sq_is_linear_square T.a126710 == True+sq_is_linear_square :: Square_Linear t -> Bool+sq_is_linear_square l = length l `T.elem_ordered` T.a000290++-- | Calculate degree of linear square, ie. square root of 'length'.+--+-- > sq_linear_degree T.a126710 == 4+sq_linear_degree :: Square_Linear t -> Int+sq_linear_degree =+    fromMaybe (error "sq_linear_degree") .+    flip T.elemIndex_ordered T.a000290 .+    length++-- | Type specialised 'transpose'+sq_transpose :: Square t -> Square t+sq_transpose = transpose++{- | Full upper-left (ul) to lower-right (lr) diagonals of a square.++> sq = sq_from_list 4 T.a126710+> sq_wr $ sq+> sq_wr $ sq_diagonals_ul_lr sq+> sq_wr $ sq_diagonals_ll_ur sq+> sq_undiagonals_ul_lr (sq_diagonals_ul_lr sq) == sq+> sq_undiagonals_ll_ur (sq_diagonals_ll_ur sq) == sq++> sq_diagonal_ul_lr sq == sq_diagonals_ul_lr sq !! 0+> sq_diagonal_ll_ur sq == sq_diagonals_ll_ur sq !! 0++-}+sq_diagonals_ul_lr :: Square t -> Square t+sq_diagonals_ul_lr = sq_transpose . zipWith T.rotate_left [0..]++-- | Full lower-left (ll) to upper-right (ur) diagonals of a square.+sq_diagonals_ll_ur :: Square t -> Square t+sq_diagonals_ll_ur = sq_diagonals_ul_lr . reverse++-- | Inverse of 'diagonals_ul_lr'+sq_undiagonals_ul_lr :: Square t -> Square t+sq_undiagonals_ul_lr = zipWith T.rotate_right [0..] . sq_transpose++-- | Inverse of 'diagonals_ll_ur'+sq_undiagonals_ll_ur :: Square t -> Square t+sq_undiagonals_ll_ur = reverse . sq_undiagonals_ul_lr++-- | Main diagonal (upper-left -> lower-right)+sq_diagonal_ul_lr :: Square t -> [t]+sq_diagonal_ul_lr sq = zipWith (!!) sq [0 ..]++-- | Main diagonal (lower-left -> upper-right)+sq_diagonal_ll_ur :: Square t -> [t]+sq_diagonal_ll_ur = sq_diagonal_ul_lr . reverse++{- | Horizontal reflection (ie. map reverse).++> sq = sq_from_list 4 T.a126710+> sq_wr $ sq+> sq_wr $ sq_h_reflection sq++-}+sq_h_reflection :: Square t -> Square t+sq_h_reflection = map reverse++-- | An n×n square is /normal/ if it has the elements (1 .. n×n).+sq_is_normal :: Integral n => Square n -> Bool+sq_is_normal sq =+  let n = genericLength sq+  in sort (concat sq) == [1 .. n * n]++-- | Sums of (rows, columns, left-right-diagonals, right-left-diagonals)+sq_sums :: Num n => Square n -> ([n],[n],[n],[n])+sq_sums sq =+  (map sum sq+  ,map sum (sq_transpose sq)+  ,map sum (sq_diagonals_ul_lr sq)+  ,map sum (sq_diagonals_ll_ur sq))++-- * PP++sq_opt :: T.Text_Table_Opt+sq_opt = (False,True,False," ",False)++sq_pp :: Show t => Square t -> String+sq_pp = unlines . T.table_pp_show sq_opt++sq_wr :: Show t => Square t -> IO ()+sq_wr = putStrLn . ('\n' :) . sq_pp++sq_pp_m :: Show t => String -> Square (Maybe t) -> String+sq_pp_m e = unlines . T.table_pp sq_opt . map (map (maybe e (T.pad_left '·' 2 . show)))++sq_wr_m :: Show t => String -> Square (Maybe t) -> IO ()+sq_wr_m e = putStrLn . sq_pp_m e++-- * Square Map++-- | (row,column) index.+type Square_Ix = T.Ix Int++-- | Map from Square_Ix to value.+type Square_Map t = Map.Map Square_Ix t++-- | 'Square' to 'Square_Map'.+sq_to_map :: Square t -> Square_Map t+sq_to_map =+    let f r = zipWith (\c e -> ((r,c),e)) [0..]+    in Map.fromList . concat . zipWith f [0..]++-- | Alias for 'Map.!'+sqm_ix :: Square_Map t -> Square_Ix -> t+sqm_ix = (Map.!)++-- | 'map' of 'sqm_ix'.+sqm_ix_seq :: Square_Map t -> [Square_Ix] -> [t]+sqm_ix_seq m = map (sqm_ix m)++-- | Make a 'Square' of dimension /dm/ that has elements from /m/ at+-- indicated indices, else 'Nothing'.+sqm_to_partial_sq :: Int -> Square_Map t -> [Square_Ix] -> Square (Maybe t)+sqm_to_partial_sq dm m ix_set =+    let f i = if i `elem` ix_set then Just (m Map.! i) else Nothing+    in Split.chunksOf dm (map f (T.matrix_indices (dm,dm)))++-- * TRS SEQ++sq_trs_op :: [(String,Square t -> Square t)]+sq_trs_op =+    [("≡",id)+    ,("←",sq_h_reflection)+    ,("↓",sq_transpose)+    ,("(← · ↓)",sq_h_reflection . sq_transpose)+    ,("(↓ · ← · ↓)",sq_transpose . sq_h_reflection . sq_transpose)+    ,("(↓ · ←)",sq_transpose . sq_h_reflection)+    ,("(← · ↓ · ←)",sq_h_reflection . sq_transpose . sq_h_reflection)+    ,("↘",sq_diagonals_ul_lr)+    ,("↙ = (↘ · ←)",sq_diagonals_ul_lr . sq_h_reflection)+    ,("↗ = (← · ↙)",sq_h_reflection . sq_diagonals_ul_lr . sq_h_reflection)+    ,("↖ = (← · ↘)",sq_h_reflection . sq_diagonals_ul_lr)+    ]++sq_trs_seq :: Square t -> [(String,Square t)]+sq_trs_seq sq = map (\(nm,fn) -> (nm,fn sq)) sq_trs_op+
− Music/Theory/Array/Text.hs 
@@ -1,123 +0,0 @@--- | Regular array data as plain text tables.-module Music.Theory.Array.Text where--import Data.List {- base -}--import qualified Data.List.Split as Split {- split -}--import qualified Music.Theory.Array as T {- hmt -}-import qualified Music.Theory.Function as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.String as T {- hmt -}---- | Tabular text.-type TABLE = [[String]]---- | Split table at indicated places.------ > let tbl = [["1","2","3","4"],["A","B","E","F"],["C","D","G","H"]]--- > table_split [2,2] tbl-table_split :: [Int] -> TABLE -> [TABLE]-table_split pl dat = transpose (map (Split.splitPlaces pl) dat)---- | Join tables left to right.------ > table_concat [[["1","2"],["A","B"],["C","D"]],[["3","4"],["E","F"],["G","H"]]]-table_concat :: [TABLE] -> TABLE-table_concat sq = map concat (transpose sq)---- | Add a row number column at the front of the table.------ > table_number_rows 0 tbl-table_number_rows :: Int -> TABLE -> TABLE-table_number_rows k dat = map (\(i,r) -> show i : r) (zip [k ..] dat)--{- | (HEADER,PAD-LEFT,EQ-WIDTH,COL-SEP,TBL-DELIM).--Options are:- has header- pad text with space to left instead of right,- make all columns equal width,- column separator string,- print table delimiters--}-type TABLE_OPT = (Bool,Bool,Bool,String,Bool)---- | Options for @simple@ layout.-table_opt_simple :: TABLE_OPT-table_opt_simple = (True,True,False," ",True)---- | Options for @pipe@ layout.-table_opt_pipe :: TABLE_OPT-table_opt_pipe = (True,True,False," | ",False)---- | Pretty-print table.  Table is in row order.------ > let tbl = [["1","2","3","4"],["a","bc","def"],["ghij","klm","no","p"]]--- > putStrLn$unlines$"": table_pp (True,True,True," ",True) tbl--- > putStrLn$unlines$"": table_pp (False,False,True," ",False) tbl-table_pp :: TABLE_OPT -> TABLE -> [String]-table_pp (has_hdr,pad_left,eq_width,col_sep,print_eot) dat =-    let c = transpose (T.tbl_make_regular_nil "" dat)-        nc = length c-        n = let k = map (maximum . map length) c-            in if eq_width then replicate nc (maximum k) else k-        ext k s = if pad_left then T.pad_left ' ' k s else T.pad_right ' ' k s-        jn = intercalate col_sep-        m = jn (map (flip replicate '-') n)-        w = map jn (transpose (zipWith (map . ext) n c))-        d = map T.delete_trailing_whitespace w-        pr x = if print_eot then T.bracket (m,m) x else x-    in case d of-         [] -> error "table_pp"-         d0:dr -> if has_hdr then d0 : pr dr else pr d---- | Variant relying on 'Show' instances.------ > table_pp_show table_opt_simple [[1..4],[5..8],[9..12]]-table_pp_show :: Show t => TABLE_OPT -> T.Table t -> [String]-table_pp_show opt = table_pp opt . map (map show)---- | Variant in column order (ie. 'transpose').------ > table_pp_column_order table_opt_simple [["a","bc","def"],["ghij","klm","no"]]-table_pp_column_order :: TABLE_OPT -> TABLE -> [String]-table_pp_column_order opt = table_pp opt . transpose--{- | Matrix form, ie. header in both first row and first column, in-each case displaced by one location which is empty.--> let h = (map return "abc",map return "efgh")-> let t = table_matrix h (map (map show) [[1,2,3,4],[2,3,4,1],[3,4,1,2]])-->>> putStrLn $ unlines $ table_pp table_opt_simple t-- - - - --  e f g h-a 1 2 3 4-b 2 3 4 1-c 3 4 1 2-- - - - ----}-table_matrix :: ([String],[String]) -> TABLE -> TABLE-table_matrix (r,c) t = table_concat [[""] : map return r,c : t]---- | Variant that takes a 'show' function and a /header decoration/ function.------ > table_matrix_opt show id ([1,2,3],[4,5,6]) [[7,8,9],[10,11,12],[13,14,15]]-table_matrix_opt :: (a -> String) -> (String -> String) -> ([a],[a]) -> T.Table a -> TABLE-table_matrix_opt show_f hd_f nm t =-    let nm' = T.bimap1 (map (hd_f . show_f)) nm-        t' = map (map show_f) t-    in table_matrix nm' t'--{---- | Two-tuple 'show' variant.-table_table_p2 :: (Show a,Show b) => TABLE_Opt -> Maybe [String] -> ([a],[b]) -> [String]-table_table_p2 opt hdr (p,q) = table_table' opt hdr [map show p,map show q]---- | Three-tuple 'show' variant.-table_table_p3 :: (Show a,Show b,Show c) => TABLE_Opt -> Maybe [String] -> ([a],[b],[c]) -> [String]-table_table_p3 opt hdr (p,q,r) = table_table' opt hdr [map show p,map show q,map show r]---}
− Music/Theory/Bits.hs 
@@ -1,38 +0,0 @@--- | Bits functions.-module Music.Theory.Bits where--import Data.Bits {- base -}--bit_pp :: Bool -> Char-bit_pp b = if b then '1' else '0'--bits_pp :: [Bool] -> String-bits_pp = map bit_pp---- | Generate /n/ place bit sequence for /x/.-gen_bitseq :: FiniteBits b => Int -> b -> [Bool]-gen_bitseq n x =-    if finiteBitSize x < n-    then error "gen_bitseq"-    else map (testBit x) (reverse [0 .. n - 1])---- | Given bit sequence (most to least significant) generate 'Bits' value.------ > :set -XBinaryLiterals--- > pack_bitseq [True,False,True,False] == 0b1010--- > pack_bitseq [True,False,False,True,False,False] == 0b100100--- > 0b100100 == 36-pack_bitseq :: Bits i => [Bool] -> i-pack_bitseq =-    last .-    scanl (\n (k,b) -> if b then setBit n k else n) zeroBits .-    zip [0..] .-    reverse---- | 'bits_pp' of 'gen_bitseq'.------ > :set -XBinaryLiterals--- > 0xF0 == 0b11110000--- > gen_bitseq_pp 8 (0xF0::Int) == "11110000"-gen_bitseq_pp :: FiniteBits b => Int -> b -> String-gen_bitseq_pp n = bits_pp . gen_bitseq n
Music/Theory/Bjorklund.hs view
@@ -9,37 +9,39 @@  import qualified Music.Theory.List as T -type STEP a = ((Int,Int),([[a]],[[a]]))+-- | Bjorklund state+type BJORKLUND_ST a = ((Int,Int),([[a]],[[a]])) -left :: STEP a -> STEP a-left ((i,j),(xs,ys)) =+-- | Bjorklund left process+bjorklund_left_f :: BJORKLUND_ST a -> BJORKLUND_ST a+bjorklund_left_f ((i,j),(xs,ys)) =     let (xs',xs'') = splitAt j xs     in ((j,i-j),(zipWith (++) xs' ys,xs'')) -right :: STEP a -> STEP a-right ((i,j),(xs,ys)) =+-- | Bjorklund right process+bjorklund_right_f :: BJORKLUND_ST a -> BJORKLUND_ST a+bjorklund_right_f ((i,j),(xs,ys)) =     let (ys',ys'') = splitAt i ys     in ((i,j-i),(zipWith (++) xs ys',ys'')) -bjorklund' :: STEP a -> STEP a-bjorklund' (n,x) =+-- | Bjorklund process, left & recur or right & recur or halt.+bjorklund_f :: BJORKLUND_ST a -> BJORKLUND_ST a+bjorklund_f (n,x) =     let (i,j) = n     in if min i j <= 1        then (n,x)-       else bjorklund' (if i > j then left (n,x) else right (n,x))+       else bjorklund_f (if i > j then bjorklund_left_f (n,x) else bjorklund_right_f (n,x))  {- | Bjorklund's algorithm to construct a binary sequence of /n/ bits with /k/ ones such that the /k/ ones are distributed as evenly as possible among the (/n/ - /k/) zeroes.  > bjorklund (5,9) == [True,False,True,False,True,False,True,False,True]-> map xdot (bjorklund (5,9)) == "x.x.x.x.x"+> map xdot_ascii (bjorklund (5,9)) == "x.x.x.x.x" -> let {es = [(2,[3,5]),(3,[4,5,8]),(4,[7,9,12,15]),(5,[6,7,8,9,11,12,13,16])->           ,(6,[7,13]),(7,[8,9,10,12,15,16,17,18]),(8,[17,19])->           ,(9,[14,16,22,23]),(11,[12,24]),(13,[24]),(15,[34])]->     ;es' = concatMap (\(i,j) -> map ((,) i) j) es}-> in mapM_ (putStrLn . euler_pp') es'+> let es = [(2,[3,5]),(3,[4,5,8]),(4,[7,9,12,15]),(5,[6,7,8,9,11,12,13,16]),(6,[7,13]),(7,[8,9,10,12,15,16,17,18]),(8,[17,19]),(9,[14,16,22,23]),(11,[12,24]),(13,[24]),(15,[34])]+> let es' = concatMap (\(i,j) -> map ((,) i) j) es+> mapM_ (putStrLn . euler_pp_unicode) es'  > > E(2,3) [××·] (12) > > E(2,5) [×·×··] (23)@@ -85,12 +87,12 @@     let j = j' - i         x = replicate i [True]         y = replicate j [False]-        (_,(x',y')) = bjorklund' ((i,j),(x,y))+        (_,(x',y')) = bjorklund_f ((i,j),(x,y))     in concat x' ++ concat y'  -- | 'T.rotate_right' of 'bjorklund'. ----- > map xdot' (bjorklund_r 2 (5,16)) == "··×··×··×··×··×·"+-- > map xdot_unicode (bjorklund_r 2 (5,16)) == "··×··×··×··×··×·" bjorklund_r :: Int -> (Int, Int) -> [Bool] bjorklund_r n = T.rotate_right n . bjorklund @@ -102,40 +104,37 @@  -- | Unicode form, ie. @×·@. ----- > euler_pp' (7,12) == "E(7,12) [×·××·×·××·×·] (2122122)"-euler_pp' :: (Int, Int) -> String-euler_pp' = euler_pp_f xdot'+-- > euler_pp_unicode (7,12) == "E(7,12) [×·××·×·××·×·] (2122122)"+euler_pp_unicode :: (Int, Int) -> String+euler_pp_unicode = euler_pp_f xdot_unicode  -- | ASCII form, ie. @x.@. ----- > euler_pp (7,12) == "E(7,12) [x.xx.x.xx.x.] (2122122)"-euler_pp :: (Int, Int) -> String-euler_pp = euler_pp_f xdot+-- > euler_pp_ascii (7,12) == "E(7,12) [x.xx.x.xx.x.] (2122122)"+euler_pp_ascii :: (Int, Int) -> String+euler_pp_ascii = euler_pp_f xdot_ascii  -- | /xdot/ notation for pattern. ----- > map xdot (bjorklund (5,9)) == "x.x.x.x.x"-xdot :: Bool -> Char-xdot x = if x then 'x' else '.'+-- > map xdot_ascii (bjorklund (5,9)) == "x.x.x.x.x"+xdot_ascii :: Bool -> Char+xdot_ascii x = if x then 'x' else '.'  -- | Unicode variant. ----- > map xdot' (bjorklund (5,12)) == "×··×·×··×·×·"--- > map xdot' (bjorklund (5,16)) == "×··×··×··×··×···"-xdot' :: Bool -> Char-xdot' x = if x then '×' else '·'+-- > map xdot_unicode (bjorklund (5,12)) == "×··×·×··×·×·"+-- > map xdot_unicode (bjorklund (5,16)) == "×··×··×··×··×···"+xdot_unicode :: Bool -> Char+xdot_unicode x = if x then '×' else '·'  -- | The 'iseq' of a pattern is the distance between 'True' values. -- -- > iseq (bjorklund (5,9)) == [2,2,2,2,1] iseq :: [Bool] -> [Int]-iseq =-    let f = split . keepDelimsL . whenElt-    in tail . map length . f (== True)+iseq = let f = split . keepDelimsL . whenElt in tail . map length . f (== True)  -- | 'iseq' of pattern as compact string. -- -- > iseq_str (bjorklund (5,9)) == "(22221)" iseq_str :: [Bool] -> String-iseq_str = let f xs = "(" ++ concatMap show xs ++ ")"-           in f . iseq+iseq_str = let f xs = "(" ++ concatMap show xs ++ ")" in f . iseq
Music/Theory/Braille.hs view
@@ -103,7 +103,7 @@ -- -- > braille_lookup_ascii 'N' == Just (0x4E,'N',[1,3,4,5],'⠝',"n") braille_lookup_ascii :: Char -> Maybe BRAILLE-braille_lookup_ascii c = find ((== (toUpper c)) . braille_ascii) braille_table+braille_lookup_ascii c = find ((== toUpper c) . braille_ascii) braille_table  -- | The arrangement of the 6-dot patterns into /decades/, sequences -- of (1,10,3) cells.  The cell to the left of the decade is the empty@@ -160,6 +160,7 @@     let f n = if n `elem` d then b else w     in map (map f) [[1,4],[2,5],[3,6]] +-- | 'lines' as rows and 'Char' as cells in HTML table. string_html_table :: String -> String string_html_table s =     let f x = "<td>" ++ [x] ++ "</td>"
− Music/Theory/Byte.hs 
@@ -1,145 +0,0 @@--- | Byte functions.-module Music.Theory.Byte where--import Data.Char {- base -}-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"]-byte_hex_pp :: (Integral i, Show i) => i -> Maybe String-byte_hex_pp n =-    case showHex n "" of-      [c] -> Just ['0',toUpper c]-      [c,d] -> Just (map toUpper [c,d])-      _ -> Nothing---- | Erroring variant.-byte_hex_pp_err :: (Integral i, Show i) => i -> String-byte_hex_pp_err = fromMaybe (error "byte_hex_pp") . byte_hex_pp---- | '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 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.------ > 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 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_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' 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' sequences as hexadecimal text, one sequence per line.-store_hex_byte_seq :: (Integral i,Show i) => FilePath -> [[i]] -> IO ()-store_hex_byte_seq fn = writeFile fn . unlines . map (byte_seq_hex_pp False)--{---import qualified Data.ByteString.Base64 as Base64 {- base64-bytestring -}-let fn = "/home/rohan/sw/hsc3-data/data/yamaha/dx7/rom/ROM1A.syx"-b <- load_byte_seq fn :: IO [Word8]-let e = B.unpack (Base64.encode (B.pack b))-let r = B.unpack (Base64.decodeLenient (B.pack e))-(length b,length e,length r,b == r) == (4104,5472,4104,True)-map word8_to_char e---}
Music/Theory/Clef.hs view
@@ -5,11 +5,11 @@ import Music.Theory.Pitch.Name {- hmt -}  -- | Clef enumeration type.-data Clef_T = Bass | Tenor | Alto | Treble | Percussion+data Clef_Type = Bass | Tenor | Alto | Treble | Percussion               deriving (Eq,Ord,Show)  -- | Clef with octave offset.-data Clef i = Clef {clef_t :: Clef_T+data Clef i = Clef {clef_t :: Clef_Type                    ,clef_octave :: i}               deriving (Eq,Ord,Show) @@ -18,7 +18,7 @@ -- -- > map clef_range [Treble,Bass] == [Just (d4,g5),Just (f2,b3)] -- > clef_range Percussion == Nothing-clef_range :: Clef_T -> Maybe (Pitch,Pitch)+clef_range :: Clef_Type -> Maybe (Pitch,Pitch) clef_range c =     case c of       Bass -> Just (f2,b3)
− Music/Theory/Combinations.hs 
@@ -1,22 +0,0 @@--- | Combination functions.-module Music.Theory.Combinations where--import qualified Music.Theory.Permutations as T---- | Number of /k/ element combinations of a set of /n/ elements.------ > 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---- | /k/ element subsets of /s/.------ > combinations 3 [1..4] == [[1,2,3],[1,2,4],[1,3,4],[2,3,4]]--- > length (combinations 3 [1..5]) == nk_combinations 5 3--- > combinations 3 "xyzw" == ["xyz","xyw","xzw","yzw"]-combinations :: Int -> [a] -> [[a]]-combinations k s =-    case (k,s) of-      (0,_) -> [[]]-      (_,[]) -> []-      (_,e:s') -> map (e :) (combinations (k - 1) s') ++ combinations k s'
Music/Theory/Contour/Polansky_1992.hs view
@@ -10,10 +10,11 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import qualified Music.Theory.List as T-import qualified Music.Theory.Ord as T-import qualified Music.Theory.Permutations.List as T-import qualified Music.Theory.Set.List as T+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Ord as T {- hmt-base -}++import qualified Music.Theory.Permutations.List as T {- hmt -}+import qualified Music.Theory.Set.List as T {- hmt -}  -- * Indices
− Music/Theory/DB/CSV.hs 
@@ -1,24 +0,0 @@--- | Keys are given in the header, empty fields are omitted from records.-module Music.Theory.DB.CSV where--import Data.Maybe {- base -}-import qualified Text.CSV.Lazy.String as C {- lazy-csv -}--import Music.Theory.DB.Common {- hmt -}-import qualified Music.Theory.IO as T {- hmt -}---- | Load 'DB' from 'FilePath'.-db_load_utf8 :: FilePath -> IO DB'-db_load_utf8 fn = do-  s <- T.read_file_utf8 fn-  let p = C.fromCSVTable (C.csvTable (C.parseCSV s))-      (h,d) = (head p,tail p)-      f k v = if null v then Nothing else Just (k,v)-  return (map (catMaybes . zipWith f h) d)--db_store_utf8 :: FilePath -> DB' -> IO ()-db_store_utf8 fn db = do-  let (hdr,tbl) = db_to_table (fromMaybe "") db-      (_,tbl') = C.toCSVTable (hdr : tbl)-      str = C.ppCSVTable tbl'-  T.write_file_utf8 fn str
− Music/Theory/DB/Common.hs 
@@ -1,130 +0,0 @@-module Music.Theory.DB.Common where--import Data.List {- base -}-import Data.Maybe {- base -}-import Safe {- safe -}--import qualified Music.Theory.List as T {- base -}-import qualified Music.Theory.Maybe as T {- base -}---- * Type--type Entry k v = (k,v)-type Record k v = [Entry k v]-type DB k v = [Record k v]--type Key = String-type Value = String-type Entry' = Entry Key Value-type Record' = Record Key Value-type DB' = DB Key Value---- * Record---- | The sequence of keys at 'Record'.-record_key_seq :: Record k v -> [k]-record_key_seq = map fst---- | 'True' if 'Key' is present in 'Entity'.-record_has_key :: Eq k => k -> Record k v -> Bool-record_has_key k = elem k . record_key_seq---- | 'T.histogram' of 'record_key_seq'.-record_key_histogram :: Ord k => Record k v -> [(k,Int)]-record_key_histogram = T.histogram . record_key_seq---- | Duplicate keys predicate.-record_has_duplicate_keys :: Ord k => Record k v -> Bool-record_has_duplicate_keys = any (> 0) . map snd . record_key_histogram---- | Find all associations for key using given equality function.-record_lookup_by :: (k -> k -> Bool) -> k -> Record k v -> [v]-record_lookup_by f k = map snd . filter (f k . fst)---- | 'record_lookup_by' of '=='.-record_lookup :: Eq k => k -> Record k v -> [v]-record_lookup = record_lookup_by (==)---- | /n/th element of 'record_lookup'.-record_lookup_at :: Eq k => (k,Int) -> Record k v -> Maybe v-record_lookup_at (c,n) = flip atMay n . record_lookup c---- | Variant of 'record_lookup' requiring a unique key.  'Nothing' indicates--- there is no entry, it is an 'error' if duplicate keys are present.-record_lookup_uniq :: Eq k => k -> Record k v -> Maybe v-record_lookup_uniq k r =-    case record_lookup k r of-      [] -> Nothing-      [v] -> Just v-      _ -> error "record_lookup_uniq: non uniq"---- | 'True' if key exists and is unique.-record_has_key_uniq :: Eq k => k -> Record k v -> Bool-record_has_key_uniq k = isJust . record_lookup_uniq k---- | Error variant.-record_lookup_uniq_err :: Eq k => k -> Record k v -> v-record_lookup_uniq_err k = T.from_just "record_lookup_uniq: none" . record_lookup_uniq k---- | Default value variant.-record_lookup_uniq_def :: Eq k => v -> k -> Record k v -> v-record_lookup_uniq_def v k = fromMaybe v . record_lookup_uniq k---- | Remove all associations for key using given equality function.-record_delete_by :: (k -> k -> Bool) -> k -> Record k v -> Record k v-record_delete_by f k = filter (not . f k . fst)---- | 'record_delete_by' of '=='.-record_delete :: Eq k => k -> Record k v -> Record k v-record_delete = record_delete_by (==)---- * DB---- | Preserves order of occurence.-db_key_set :: Ord k => DB k v -> [k]-db_key_set = nub . map fst . concat--db_lookup_by :: (k -> k -> Bool) -> (v -> v -> Bool) -> k -> v -> DB k v -> [Record k v]-db_lookup_by k_cmp v_cmp k v =-    let f = any (v_cmp v) . record_lookup_by k_cmp k-    in filter f--db_lookup :: (Eq k,Eq v) => k -> v -> DB k v -> [Record k v]-db_lookup = db_lookup_by (==) (==)--db_has_duplicate_keys :: Ord k => DB k v -> Bool-db_has_duplicate_keys = any id . map record_has_duplicate_keys--db_key_histogram :: Ord k => DB k v -> [(k,Int)]-db_key_histogram db =-    let h = concatMap record_key_histogram db-        f k = (k,maximum (record_lookup k h))-    in map f (db_key_set db)--db_to_table :: Ord k => (Maybe v -> e) -> DB k v -> ([k],[[e]])-db_to_table f db =-    let kh = db_key_histogram db-        hdr = concatMap (\(k,n) -> replicate n k) kh-        ix = concatMap (\(k,n) -> zip (repeat k) [0 .. n - 1]) kh-    in (hdr,map (\r -> map (\i -> f (record_lookup_at i r)) ix) db)---- * Collating duplicate keys.--record_collate' :: Eq k => (k,[v]) -> Record k v -> Record k [v]-record_collate' (k,v) r =-    case r of-      [] -> [(k,reverse v)]-      (k',v'):r' ->-          if k == k'-          then record_collate' (k,v' : v) r'-          else (k,reverse v) : record_collate' (k',[v']) r'---- | Collate adjacent entries of existing sequence with equal key.-record_collate :: Eq k => Record k v -> Record k [v]-record_collate r =-    case r of-      [] -> error "record_collate: nil"-      (k,v):r' -> record_collate' (k,[v]) r'--record_uncollate :: Record k [v] -> Record k v-record_uncollate = concatMap (\(k,v) -> zip (repeat k) v)
− Music/Theory/DB/JSON.hs 
@@ -1,67 +0,0 @@--- | JSON string association database.--- JSON objects do no allow multiple keys.--- Here multiple keys are read & written as arrays.-module Music.Theory.DB.JSON where--import qualified Data.Aeson as A {- aeson -}-import qualified Data.ByteString.Lazy as B {- bytestring -}-import qualified Data.Map as M {- containers -}--import qualified Music.Theory.DB.Common as DB---- | Load 'DB' from 'FilePath'.-db_load_utf8 :: FilePath -> IO DB.DB'-db_load_utf8 fn = do-  b <- B.readFile fn-  case A.decode b of-    Just m ->-        let f = DB.record_uncollate .-                map (fmap maybe_list_to_list) .-                M.toList-        in return (map f m)-    Nothing -> return []---- | Store 'DB' to 'FilePath'.------ > let fn = "/home/rohan/ut/www-spr/data/db.js"--- > db <- db_load_utf8 fn--- > length db == 1334--- > db_store_utf8 "/tmp/sp.js" db-db_store_utf8 :: FilePath -> DB.DB' -> IO ()-db_store_utf8 fn db = do-  let db' = let f = map (fmap list_to_maybe_list) . DB.record_collate-            in map f db-      b = A.encode (map M.fromList db')-  B.writeFile fn b---- * Maybe List of String--data Maybe_List_Of_String = S String | L [String] deriving (Eq,Show)--maybe_list_to_list :: Maybe_List_Of_String -> [String]-maybe_list_to_list m =-    case m of-      S s -> [s]-      L l -> l--list_to_maybe_list :: [String] -> Maybe_List_Of_String-list_to_maybe_list l =-    case l of-      [s] -> S s-      _ -> L l---- > A.toJSON (S "x")--- > A.toJSON (L ["x","y"])-instance A.ToJSON Maybe_List_Of_String where-    toJSON (S s) = A.toJSON s-    toJSON (L l) = A.toJSON l---- > :set -XOverloadedStrings--- > A.decode "\"x\"" :: Maybe Maybe_List_Of_String--- > A.decode "[\"x\",\"y\"]" :: Maybe Maybe_List_Of_String-instance A.FromJSON Maybe_List_Of_String where-    parseJSON v =-        case v of-          A.String _ -> fmap S (A.parseJSON v)-          A.Array _ -> fmap L (A.parseJSON v)-          _ -> error "parseJSON: Maybe_List_String"
− Music/Theory/DB/Plain.hs 
@@ -1,60 +0,0 @@--- | @key: value@ database, allows duplicate @key@s.-module Music.Theory.DB.Plain where--import Data.List {- base -}-import qualified Data.List.Split as Split {- split -}-import Data.Maybe {- base -}-import qualified Safe as Safe {- safe -}--import qualified Music.Theory.IO as IO {- hmt -}-import qualified Music.Theory.List as T {- hmt -}---- | (RECORD-SEPARATOR,FIELD-SEPARATOR,ENTRY-SEPARATOR)-type SEP = (String,String,String)--type Key = String-type Value = String-type Entry = (Key,[Value])-type Record = [Entry]-type DB = [Record]--sep_plain :: SEP-sep_plain = (['\n','\n'],['\n'],": ")---- > record_parse (";","=") "F=f/rec;E=au;C=A;K=P;K=Q"-record_parse :: (String,String) -> String -> Record-record_parse (fs,es) = T.collate_adjacent . mapMaybe (T.separate_at es) . Split.splitOn fs--record_lookup :: Key -> Record -> [Value]-record_lookup k = fromMaybe [] . lookup k--record_lookup_at :: (Key,Int) -> Record -> Maybe Value-record_lookup_at (k,n) = flip Safe.atMay n . record_lookup k--record_has_key :: Key -> Record -> Bool-record_has_key k = isJust . lookup k--record_lookup_uniq :: Key -> Record -> Maybe Value-record_lookup_uniq k r =-    case record_lookup k r of-      [] -> Nothing-      [v] -> Just v-      _ -> error "record_lookup_uniq: non uniq"--db_parse :: SEP -> String -> [Record]-db_parse (rs,fs,es) s =-    let r = Split.splitOn rs s-    in map (record_parse (fs,es)) r--db_sort :: [(Key,Int)] -> [Record] -> [Record]-db_sort k = T.sort_by_n_stage_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---- > record_pp (";","=") [("F","f/rec.au"),("C","A")]-record_pp :: (String,String) -> Record -> String-record_pp (fs,es) = intercalate fs . map (\(k,v) -> k ++ es ++ v) . T.uncollate--db_store_utf8 :: SEP -> FilePath -> [Record] -> IO ()-db_store_utf8 (rs,fs,es) fn = IO.write_file_utf8 fn . intercalate rs . map (record_pp (fs,es))
+ Music/Theory/Db/Cli.hs view
@@ -0,0 +1,52 @@+module Music.Theory.Db.Cli where++import qualified Music.Theory.Db.Csv as Csv {- hmt -}+import qualified Music.Theory.Db.Common as Common {- hmt -}+--import qualified Music.Theory.Db.Json as Json {- hmt -}+import qualified Music.Theory.Db.Plain as Plain {- hmt -}++db_load_ty :: String -> FilePath -> IO (Common.Db String String)+db_load_ty ty fn =+    case ty of+      "plain" -> fmap (map Common.record_uncollate) (Plain.db_load_utf8 Plain.sep_plain fn)+      --"json" -> JSON.db_load_utf8 fn+      "csv" -> Csv.db_load_utf8 fn+      _ -> error "db_load_ty"++db_store_ty :: String -> FilePath -> Common.Db String String -> IO ()+db_store_ty ty fn =+    case ty of+      "plain" -> Plain.db_store_utf8 Plain.sep_plain fn . map Common.record_collate+      --"json" -> JSON.db_store_utf8 fn+      "csv" -> Csv.db_store_utf8 fn+      _ -> error "db_store_ty"++-- > convert ("plain","csv") ("/home/rohan/ut/www-spr/data/db.text","/tmp/t.csv")+-- > convert ("csv","json") ("/tmp/t.csv","/tmp/t.json")+convert :: (String,String) -> (FilePath,FilePath) -> IO ()+convert (input_ty,output_ty) (input_fn,output_fn) = do+  db <- db_load_ty input_ty input_fn+  db_store_ty output_ty output_fn db++-- > stat "plain" "/home/rohan/ut/inland/db/artists.text"+stat :: String -> FilePath -> IO ()+stat ty fn = do+  db <- db_load_ty ty fn+  let ks = Common.db_key_set db+  print ("#-records",length db)+  print ("#-keys",length ks)+  print ("key-set",unwords ks)++help :: [String]+help =+    ["convert input-type output-type input-file output-file"+    ,"stat type file-name"+    ,""+    ,"  type = csv | plain"] -- json++db_cli :: [String] -> IO ()+db_cli arg = do+  case arg of+    ["convert",i_ty,o_ty,i_fn,o_fn] -> convert (i_ty,o_ty) (i_fn,o_fn)+    ["stat",ty,fn] -> stat ty fn+    _ -> putStrLn (unlines help)
+ Music/Theory/Db/Common.hs view
@@ -0,0 +1,131 @@+-- | Database as [[(key,value)]]+module Music.Theory.Db.Common where++import Data.List {- base -}+import Data.Maybe {- base -}+import Safe {- safe -}++import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Maybe as T {- hmt-base -}++-- * Type++type Entry k v = (k,v)+type Record k v = [Entry k v]+type Db k v = [Record k v]++type Key = String+type Value = String+type Entry' = Entry Key Value+type Record' = Record Key Value+type Db' = Db Key Value++-- * Record++-- | The sequence of keys at 'Record'.+record_key_seq :: Record k v -> [k]+record_key_seq = map fst++-- | 'True' if 'Key' is present in 'Entity'.+record_has_key :: Eq k => k -> Record k v -> Bool+record_has_key k = elem k . record_key_seq++-- | 'T.histogram' of 'record_key_seq'.+record_key_histogram :: Ord k => Record k v -> [(k,Int)]+record_key_histogram = T.histogram . record_key_seq++-- | Duplicate keys predicate.+record_has_duplicate_keys :: Ord k => Record k v -> Bool+record_has_duplicate_keys = any ((> 0) . snd) . record_key_histogram++-- | Find all associations for key using given equality function.+record_lookup_by :: (k -> k -> Bool) -> k -> Record k v -> [v]+record_lookup_by f k = map snd . filter (f k . fst)++-- | 'record_lookup_by' of '=='.+record_lookup :: Eq k => k -> Record k v -> [v]+record_lookup = record_lookup_by (==)++-- | /n/th element of 'record_lookup'.+record_lookup_at :: Eq k => (k,Int) -> Record k v -> Maybe v+record_lookup_at (c,n) = flip atMay n . record_lookup c++-- | Variant of 'record_lookup' requiring a unique key.  'Nothing' indicates+-- there is no entry, it is an 'error' if duplicate keys are present.+record_lookup_uniq :: Eq k => k -> Record k v -> Maybe v+record_lookup_uniq k r =+    case record_lookup k r of+      [] -> Nothing+      [v] -> Just v+      _ -> error "record_lookup_uniq: non uniq"++-- | 'True' if key exists and is unique.+record_has_key_uniq :: Eq k => k -> Record k v -> Bool+record_has_key_uniq k = isJust . record_lookup_uniq k++-- | Error variant.+record_lookup_uniq_err :: Eq k => k -> Record k v -> v+record_lookup_uniq_err k = T.from_just "record_lookup_uniq: none" . record_lookup_uniq k++-- | Default value variant.+record_lookup_uniq_def :: Eq k => v -> k -> Record k v -> v+record_lookup_uniq_def v k = fromMaybe v . record_lookup_uniq k++-- | Remove all associations for key using given equality function.+record_delete_by :: (k -> k -> Bool) -> k -> Record k v -> Record k v+record_delete_by f k = filter (not . f k . fst)++-- | 'record_delete_by' of '=='.+record_delete :: Eq k => k -> Record k v -> Record k v+record_delete = record_delete_by (==)++-- * Db++-- | Preserves order of occurence.+db_key_set :: Ord k => Db k v -> [k]+db_key_set = nub . map fst . concat++db_lookup_by :: (k -> k -> Bool) -> (v -> v -> Bool) -> k -> v -> Db k v -> [Record k v]+db_lookup_by k_cmp v_cmp k v =+    let f = any (v_cmp v) . record_lookup_by k_cmp k+    in filter f++db_lookup :: (Eq k,Eq v) => k -> v -> Db k v -> [Record k v]+db_lookup = db_lookup_by (==) (==)++db_has_duplicate_keys :: Ord k => Db k v -> Bool+db_has_duplicate_keys = any record_has_duplicate_keys++db_key_histogram :: Ord k => Db k v -> [(k,Int)]+db_key_histogram db =+    let h = concatMap record_key_histogram db+        f k = (k,maximum (record_lookup k h))+    in map f (db_key_set db)++db_to_table :: Ord k => (Maybe v -> e) -> Db k v -> ([k],[[e]])+db_to_table f db =+    let kh = db_key_histogram db+        hdr = concatMap (\(k,n) -> replicate n k) kh+        ix = concatMap (\(k,n) -> zip (repeat k) [0 .. n - 1]) kh+    in (hdr,map (\r -> map (\i -> f (record_lookup_at i r)) ix) db)++-- * Collating duplicate keys.++record_collate_from :: Eq k => (k,[v]) -> Record k v -> Record k [v]+record_collate_from (k,v) r =+    case r of+      [] -> [(k,reverse v)]+      (k',v'):r' ->+          if k == k'+          then record_collate_from (k,v' : v) r'+          else (k,reverse v) : record_collate_from (k',[v']) r'++-- | Collate adjacent entries of existing sequence with equal key.+record_collate :: Eq k => Record k v -> Record k [v]+record_collate r =+    case r of+      [] -> error "record_collate: nil"+      (k,v):r' -> record_collate_from (k,[v]) r'++record_uncollate :: Record k [v] -> Record k v+record_uncollate = concatMap (\(k,v) -> zip (repeat k) v)
+ Music/Theory/Db/Csv.hs view
@@ -0,0 +1,26 @@+-- | Keys are given in the header, empty fields are omitted from records.+module Music.Theory.Db.Csv where++import Data.Maybe {- base -}++import qualified Text.CSV.Lazy.String as C {- lazy-csv -}++import qualified Music.Theory.Io as T {- hmt-base -}++import Music.Theory.Db.Common {- hmt -}++-- | Load 'DB' from 'FilePath'.+db_load_utf8 :: FilePath -> IO Db'+db_load_utf8 fn = do+  s <- T.read_file_utf8 fn+  let p = C.fromCSVTable (C.csvTable (C.parseCSV s))+      (h,d) = (head p,tail p)+      f k v = if null v then Nothing else Just (k,v)+  return (map (catMaybes . zipWith f h) d)++db_store_utf8 :: FilePath -> Db' -> IO ()+db_store_utf8 fn db = do+  let (hdr,tbl) = db_to_table (fromMaybe "") db+      (_,tbl') = C.toCSVTable (hdr : tbl)+      str = C.ppCSVTable tbl'+  T.write_file_utf8 fn str
+ Music/Theory/Db/Plain.hs view
@@ -0,0 +1,61 @@+-- | @key: value@ database, allows duplicate @key@s.+module Music.Theory.Db.Plain where++import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Data.List.Split as Split {- split -}+import qualified Safe {- safe -}++import qualified Music.Theory.Io as Io {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}++-- | (Record-, Field-, Entry-) separators+type Sep = (String, String, String)++type Key = String+type Value = String+type Entry = (Key, [Value])+type Record = [Entry]+type Db = [Record]++sep_plain :: Sep+sep_plain = (['\n','\n'],['\n'],": ")++-- > record_parse (";","=") "F=f/rec;E=au;C=A;K=P;K=Q"+record_parse :: (String,String) -> String -> Record+record_parse (fs,es) = T.collate_adjacent . mapMaybe (T.separate_at es) . Split.splitOn fs++record_lookup :: Key -> Record -> [Value]+record_lookup k = fromMaybe [] . lookup k++record_lookup_at :: (Key,Int) -> Record -> Maybe Value+record_lookup_at (k,n) = flip Safe.atMay n . record_lookup k++record_has_key :: Key -> Record -> Bool+record_has_key k = isJust . lookup k++record_lookup_uniq :: Key -> Record -> Maybe Value+record_lookup_uniq k r =+    case record_lookup k r of+      [] -> Nothing+      [v] -> Just v+      _ -> error "record_lookup_uniq: non uniq"++db_parse :: Sep -> String -> [Record]+db_parse (rs,fs,es) s =+    let r = Split.splitOn rs s+    in map (record_parse (fs,es)) r++db_sort :: [(Key,Int)] -> [Record] -> [Record]+db_sort k = T.sort_by_n_stage_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++-- > record_pp (";","=") [("F","f/rec.au"),("C","A")]+record_pp :: (String,String) -> Record -> String+record_pp (fs,es) = intercalate fs . map (\(k,v) -> k ++ es ++ v) . T.uncollate++db_store_utf8 :: Sep -> FilePath -> [Record] -> IO ()+db_store_utf8 (rs,fs,es) fn = Io.write_file_utf8 fn . intercalate rs . map (record_pp (fs,es))
− Music/Theory/Directory.hs 
@@ -1,118 +0,0 @@--- | Directory functions.-module Music.Theory.Directory where--import Data.List {- base -}-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-      [] -> return Nothing-      dir:p' -> let nm = dir </> fn-                    f x = if x then return (Just nm) else path_scan p' fn-                in doesFileExist nm >>= f---- | Erroring variant.-path_scan_err :: [FilePath] -> FilePath -> IO FilePath-path_scan_err 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-  c <- getDirectoryContents dir-  return (map (dir </>) (sort (filter f c)))---- | If path is not absolute, prepend current working directory.------ > to_absolute_cwd "x"-to_absolute_cwd :: FilePath -> IO FilePath-to_absolute_cwd x =-    if isAbsolute x-    then return x-    else fmap (</> x) getCurrentDirectory---- | If /i/ is an existing file then /j/ else /k/.-if_file_exists :: (FilePath,IO t,IO t) -> IO t-if_file_exists (i,j,k) = T.m_if (doesFileExist i,j,k)---- | 'createDirectoryIfMissing' (including parents) and then 'writeFile'-writeFile_mkdir :: FilePath -> String -> IO ()-writeFile_mkdir fn s = do-  let dir = takeDirectory fn-  createDirectoryIfMissing True dir-  writeFile fn s---- | 'writeFile_mkdir' only if file does not exist.-writeFile_mkdir_x :: FilePath -> String -> IO ()-writeFile_mkdir_x fn txt = if_file_exists (fn,return (),writeFile_mkdir fn txt)
Music/Theory/Duration.hs view
@@ -1,7 +1,6 @@ -- | Common music notation duration model. module Music.Theory.Duration where -import Control.Monad {- base -} import Data.List {- base -} import Data.Maybe {- base -} import Data.Ratio {- base -}@@ -13,11 +12,12 @@ type Dots = Int  -- | Common music notation durational model-data Duration = Duration {division :: Division -- ^ division of whole note-                         ,dots :: Int -- ^ number of dots-                         ,multiplier :: Rational -- ^ tuplet modifier-                         }-                deriving (Eq,Show)+data Duration =+  Duration+  {division :: Division -- ^ division of whole note+  ,dots :: Int -- ^ number of dots+  ,multiplier :: Rational} -- ^ tuplet modifier+  deriving (Eq,Show)  -- | Are multipliers equal? duration_meq :: Duration -> Duration -> Bool@@ -55,48 +55,54 @@ no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0  -- | Sum undotted divisions, input is required to be sorted.-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)+sum_dur_undotted :: Rational -> (Division, Division) -> Maybe Duration+sum_dur_undotted m (x0, x1)+    | x0 == x1 = Just (Duration (x0 `div` 2) 0 m)+    | x0 == x1 * 2 = Just (Duration x1 1 m)     | otherwise = Nothing --- | Sum dotted divisions, input is required to be sorted.------ > sum_dur_dotted (4,1,4,1) == Just (Duration 2 1 1)--- > 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 :: (Division,Dots,Division,Dots) -> Maybe Duration-sum_dur_dotted (x0, n0, x1, n1)+{- | Sum dotted divisions, input is required to be sorted.++> sum_dur_dotted 1 (4,1,4,1) == Just (Duration 2 1 1)+> sum_dur_dotted 1 (4,0,2,1) == Just (Duration 1 0 1)+> sum_dur_dotted 1 (8,1,4,0) == Just (Duration 4 2 1)+> sum_dur_dotted 1 (16,0,4,2) == Just (Duration 2 0 1)+-}+sum_dur_dotted :: Rational -> (Division,Dots,Division,Dots) -> Maybe Duration+sum_dur_dotted m (x0, n0, x1, n1)     | x0 == x1 &&       n0 == 1 &&-      n1 == 1 = Just (Duration (x1 `div` 2) 1 1)+      n1 == 1 = Just (Duration (x1 `div` 2) 1 m)     | x0 == x1 * 2 &&       n0 == 0 &&-      n1 == 1 = Just (Duration (x1 `div` 2) 0 1)+      n1 == 1 = Just (Duration (x1 `div` 2) 0 m)     | x0 == x1 * 4 &&       n0 == 0 &&-      n1 == 2 = Just (Duration (x1 `div` 2) 0 1)+      n1 == 2 = Just (Duration (x1 `div` 2) 0 m)     | x0 == x1 * 2 &&       n0 == 1 &&-      n1 == 0 = Just (Duration x1 2 1)+      n1 == 0 = Just (Duration x1 2 m)     | otherwise = Nothing --- | Sum durations.  Not all durations can be summed, and the present---   algorithm is not exhaustive.------ > import Music.Theory.Duration.Name--- > sum_dur quarter_note eighth_note == Just dotted_quarter_note--- > sum_dur dotted_quarter_note eighth_note == Just half_note--- > sum_dur quarter_note dotted_eighth_note == Just double_dotted_quarter_note+{- | Sum durations.  Not all durations can be summed, and the present+     algorithm is not exhaustive.++> import Music.Theory.Duration+> import Music.Theory.Duration.Name+> sum_dur quarter_note eighth_note == Just dotted_quarter_note+> sum_dur dotted_quarter_note eighth_note == Just half_note+> sum_dur quarter_note dotted_eighth_note == Just double_dotted_quarter_note+-} sum_dur :: Duration -> Duration -> Maybe Duration sum_dur y0 y1 =-    let f (x0,x1) = if no_dots (x0,x1)-                    then sum_dur_undotted (division x0, division x1)-                    else sum_dur_dotted (division x0, dots x0-                                        ,division x1, dots x1)-    in join (fmap f (T.sort_pair_m duration_compare_meq (y0,y1)))+    let (m0,m1) = (multiplier y0,multiplier y1)+        f (x0,x1) = if m0 /= m1+                    then Nothing -- cannot sum durations with non-equal multipliers+                    else if no_dots (x0,x1)+                         then sum_dur_undotted m0 (division x0, division x1)+                         else sum_dur_dotted m0 (division x0, dots x0+                                                ,division x1, dots x1)+    in T.sort_pair_m duration_compare_meq (y0,y1) >>= f  -- | Erroring variant of 'sum_dur'. sum_dur_err :: Duration -> Duration -> Duration@@ -105,17 +111,23 @@         err = error ("sum_dur': " ++ show (y0,y1))     in fromMaybe err y2 --- | Standard divisions (from 0 to 256).  MusicXML allows @-1@ as a division (for @long@).-divisions_set :: [Division]-divisions_set = [0,1,2,4,8,16,32,64,128,256]+{- | Standard divisions (from 1 to 256).+MusicXml allows 0 for breve and -1 for long.+Negative divisors can represent any number of longer durations, -2 be a breve, -4 a long, -8 a maximus, &etc.+-}+divisions_std_set :: [Division]+divisions_std_set = [1,2,4,8,16,32,64,128,256] --- | Durations set derived from 'divisions_set' with up to /k/ dots.  Multiplier of @1@.+divisions_musicxml_set :: [Division]+divisions_musicxml_set = -1 : 0 : divisions_std_set++-- | Durations set derived from 'divisions_std_set' with up to /k/ dots.  Multiplier of @1@. duration_set :: Dots -> [Duration]-duration_set k = [Duration dv dt 1 | dv <- divisions_set, dt <- [0..k]]+duration_set k = [Duration dv dt 1 | dv <- divisions_std_set, dt <- [0..k]]  -- | Table of number of beams at notated division. beam_count_tbl :: [(Division,Int)]-beam_count_tbl = zip (-1 : divisions_set) [0,0,0,0,0,1,2,3,4,5,6]+beam_count_tbl = zip divisions_musicxml_set [0,0,0,0,0,1,2,3,4,5,6]  -- | Lookup 'beam_count_tbl'. --@@ -132,14 +144,14 @@         bc = whole_note_division_to_beam_count x     in fromMaybe err bc --- * MusicXML+-- * MusicXml --- | Table giving @MusicXML@ types for divisions.+-- | Table giving MusicXml types for divisions. division_musicxml_tbl :: [(Division,String)] division_musicxml_tbl =     let nm = ["long","breve","whole","half","quarter","eighth"              ,"16th","32nd","64th","128th","256th"]-    in zip (-1 : divisions_set) nm+    in zip divisions_musicxml_set nm  -- | Lookup 'division_musicxml_tbl'. --@@ -194,11 +206,10 @@ <http://humdrum.org/Humdrum/representations/recip.rep.html>  > let d = map (\z -> Duration z 0 1) [0,1,2,4,8,16,32]-> in map duration_recip_pp d == ["0","1","2","4","8","16","32"]+> map duration_recip_pp d == ["0","1","2","4","8","16","32"]  > let d = [Duration 1 1 (1/3),Duration 4 1 1,Duration 4 1 (2/3)]-> in map duration_recip_pp d == ["3.","4.","6."]-+> map duration_recip_pp d == ["3.","4.","6."] -} duration_recip_pp :: Duration -> String duration_recip_pp (Duration x d m) =@@ -210,20 +221,40 @@  -- * Letter +{- | Names for note divisions.+Starting from 1/32 these names haev uniqe initial letters that can be used for concise notation.+-}+whole_note_division_name_tbl :: [(Division, String)]+whole_note_division_name_tbl =+  [(64,"sixtyfourth") -- hemidemisemiquaver+  ,(32,"thirtysecond") -- demisemiquaver+  ,(16,"sixteenth") -- semiquaver+  ,(8,"eighth") -- quaver+  ,(4,"quarter") -- crotchet+  ,(2,"half") -- minim+  ,(1,"whole") -- semibreve+  ,(0,"breve")+  ,(-1,"longa")+  ,(-2,"maxima")]++whole_note_division_name :: Division -> Maybe String+whole_note_division_name = flip lookup whole_note_division_name_tbl++whole_note_division_letter_tbl :: [(Division, Char)]+whole_note_division_letter_tbl = map (\(d,n) -> (d,head n)) whole_note_division_name_tbl++  -- > mapMaybe whole_note_division_letter_pp [-2, -1, 0, 1, 2, 4, 8, 16, 32] == "mlbwhqest" 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+whole_note_division_letter_pp = flip lookup (tail whole_note_division_letter_tbl) --- > mapMaybe duration_letter_pp [Duration 4 0 1,Duration 2 1 1,Duration 8 2 1] == ["q","h'","e''"]--- > duration_letter_pp+-- > mapMaybe duration_letter_pp [Duration 4 0 1,Duration 2 1 1,Duration 8 2 1] == ["q","h.","e.."]+-- > mapMaybe duration_letter_pp [Duration 4 1 (2/3)] == ["q./2:3"] duration_letter_pp :: Duration -> Maybe String duration_letter_pp (Duration x d m) =-    let d' = genericReplicate d '\''+    let d' = genericReplicate d '.'         m' = case (numerator m,denominator m) of                (1,1) -> ""-               (1,i) -> '/' : show i-               (i,j) -> '*' : show i ++ "/" ++ show j+               (i,j) -> '/' : show i ++ ":" ++ show j     in case whole_note_division_letter_pp x of          Just x' -> Just (x' : d' ++ m')          _ -> Nothing
Music/Theory/Duration/Annotation.hs view
@@ -5,9 +5,10 @@ import Data.Ratio {- base -} import Data.Tree {- containers -} +import qualified Music.Theory.List as L {- hmt-base -}+ import Music.Theory.Duration-import Music.Theory.Duration.RQ-import qualified Music.Theory.List as L {- hmt -}+import Music.Theory.Duration.Rq  -- | Standard music notation durational model annotations data D_Annotation = Tie_Right@@ -57,7 +58,7 @@ da_tuplet (d,n) x =     let fn (p,q) = (p {multiplier = n%d},q)         k = sum (map (duration_to_rq . fst) x) / (d%1)-        ty = rq_to_duration_err (show ("da_tuplet",d,n,x,k)) k+        ty = rq_to_duration_err (show ("da_tuplet",d,n,x,k)) 2 k         t0 = [Begin_Tuplet (d,n,ty)]         ts = [t0] ++ replicate (length x - 2) [] ++ [[End_Tuplet]]         jn (p,q) z = (p,q++z)
− Music/Theory/Duration/CT.hs 
@@ -1,195 +0,0 @@--- | Functions to generate a click track from a metric structure.-module Music.Theory.Duration.CT where--import Data.Function {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}--import qualified Music.Theory.Duration.RQ as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Time_Signature as T {- hmt -}-import qualified Music.Theory.Time.Seq as T {- hmt -}---- | 1-indexed.-type Measure = Int---- | 1-indexed.-type Pulse = Int---- | Transform measures given as 'T.RQ' divisions to absolute 'T.RQ'--- locations.  /mdv/ abbreviates measure divisions.------ > mdv_to_mrq [[1,2,1],[3,2,1]] == [[0,1,3],[4,7,9]]-mdv_to_mrq :: [[T.RQ]] -> [[T.RQ]]-mdv_to_mrq = snd . mapAccumL T.dx_d' 0---- | Lookup function for ('Measure','Pulse') indexed structure.-mp_lookup_err :: [[a]] -> (Measure,Pulse) -> a-mp_lookup_err sq (m,p) =-    if m < 1 || p < 1-    then error (show ("mp_lookup_err: one indexed?",m,p))-    else (sq !! (m - 1)) !! (p - 1)---- | Comparison for ('Measure','Pulse') indices.-mp_compare :: (Measure,Pulse) -> (Measure,Pulse) -> Ordering-mp_compare = T.two_stage_compare (compare `on` fst) (compare `on` snd)---- * CT---- | Latch measures (ie. make measures contiguous, hold previous value).------ > unzip (ct_ext 10 'a' [(3,'b'),(8,'c')]) == ([1..10],"aabbbbbccc")-ct_ext :: Int -> a -> [(Measure,a)] -> [(Measure,a)]-ct_ext n def sq = T.tseq_latch def sq [1 .. n]---- | Variant that requires a value at measure one (first measure).-ct_ext1 :: Int -> [(Measure,a)] -> [(Measure,a)]-ct_ext1 n sq =-    case sq of-      (1,e) : sq' -> ct_ext n e sq'-      _ -> error "ct_ext1"---- | 'T.rts_divisions' of 'ct_ext1'.-ct_dv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [(Measure,[[T.RQ]])]-ct_dv_seq n ts = map (fmap T.rts_divisions) (ct_ext1 n ts)---- | 'ct_dv_seq' without measures numbers.-ct_mdv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.RQ]]-ct_mdv_seq n = map (concat . snd) . ct_dv_seq n---- | 'mdv_to_mrq' of 'ct_mdv_seq'.-ct_rq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.RQ]]-ct_rq n ts = mdv_to_mrq (ct_mdv_seq n ts)--ct_mp_lookup :: [[T.RQ]] -> (Measure,Pulse) -> T.RQ-ct_mp_lookup = mp_lookup_err . mdv_to_mrq--ct_m_to_rq :: [[T.RQ]] -> [(Measure,t)] -> [(T.RQ,t)]-ct_m_to_rq sq = map (\(m,c) -> (ct_mp_lookup sq (m,1),c))---- | Latch rehearsal mark sequence, only indicating marks.  Initial mark is @.@.------ > ct_mark_seq 2 [] == [(1,Just '.'),(2,Nothing)]------ > let r = [(1,Just '.'),(3,Just 'A'),(8,Just 'B')]--- > in filter (isJust . snd) (ct_mark_seq 10 [(3,'A'),(8,'B')]) == r-ct_mark_seq :: Int -> T.Tseq Measure Char -> T.Tseq Measure (Maybe Char)-ct_mark_seq n mk = T.seq_changed (ct_ext n '.' mk)---- | Indicate measures prior to marks.------ > ct_pre_mark [] == []--- > ct_pre_mark [(1,'A')] == []--- > ct_pre_mark [(3,'A'),(8,'B')] == [(2,Just ()),(7,Just ())]-ct_pre_mark :: [(Measure,a)] -> [(Measure,Maybe ())]-ct_pre_mark = mapMaybe (\(m,_) -> if m <= 1 then Nothing else Just (m - 1,Just ()))---- | Contiguous pre-mark sequence.------ > ct_pre_mark_seq 1 [(1,'A')] == [(1,Nothing)]--- > ct_pre_mark_seq 10 [(3,'A'),(8,'B')]-ct_pre_mark_seq :: Measure -> T.Tseq Measure Char -> T.Tseq Measure (Maybe ())-ct_pre_mark_seq n mk =-    let pre = ct_pre_mark mk-    in T.tseq_merge_resolve const pre (zip [1 .. n] (repeat Nothing))--ct_tempo_lseq_rq :: [[T.RQ]] -> T.Lseq (Measure,Pulse) T.RQ -> T.Lseq T.RQ T.RQ-ct_tempo_lseq_rq sq = T.lseq_tmap (ct_mp_lookup sq)---- | Interpolating lookup of tempo sequence ('T.lseq_lookup_err').-ct_tempo_at :: T.Lseq T.RQ T.RQ -> T.RQ -> Rational-ct_tempo_at = T.lseq_lookup_err compare---- | Types of nodes.-data CT_Node = CT_Mark T.RQ -- ^ The start of a measure with a rehearsal mark.-             | CT_Start T.RQ -- ^ The start of a regular measure.-             | CT_Normal T.RQ -- ^ A regular pulse.-             | CT_Edge T.RQ -- ^ The start of a pulse group within a measure.-             | CT_Pre T.RQ -- ^ A regular pulse in a measure prior to a rehearsal mark.-             | CT_End -- ^ The end of the track.-               deriving (Eq,Show)---- | Lead-in of @(pulse,tempo,count)@.-ct_leadin :: (T.RQ,Double,Int) -> T.Dseq Double CT_Node-ct_leadin (du,tm,n) = replicate n (realToFrac du * (60 / tm),CT_Normal du)---- | Prepend initial element to start of list.------ > delay1 "abc" == "aabc"-delay1 :: [a] -> [a]-delay1 l =-    case l of-      [] -> error "delay1: []"-      e:_ -> e : l--ct_measure:: T.Lseq T.RQ T.RQ -> ([T.RQ],Maybe Char,Maybe (),[[T.RQ]]) -> [(Rational,CT_Node)]-ct_measure sq (mrq,mk,pr,dv) =-    let dv' = concatMap (zip [1::Int ..]) dv-        f (p,rq,(g,du)) =-            let nm = if p == 1-                     then case mk of-                            Nothing -> CT_Start du-                            Just _ -> CT_Mark du-                     else if pr == Just ()-                          then CT_Pre du-                          else if g == 1 then CT_Edge du else CT_Normal du-            in (du * (60 / ct_tempo_at sq rq),nm)-    in map f (zip3 [1::Int ..] mrq dv')---- | Click track definition.-data CT = CT {ct_len :: Int-             ,ct_ts :: [(Measure,T.Rational_Time_Signature)]-             ,ct_mark :: [(Measure,Char)]-             ,ct_tempo :: T.Lseq (Measure,Pulse) T.RQ-             ,ct_count :: (T.RQ,Int)}-          deriving Show---- | Initial tempo, if given.-ct_tempo0 :: CT -> Maybe T.RQ-ct_tempo0 ct =-    case ct_tempo ct of-      (((1,1),_),n):_ -> Just n-      _ -> Nothing---- | Erroring variant.-ct_tempo0_err :: CT -> T.RQ-ct_tempo0_err = fromMaybe (error "ct_tempo0") . ct_tempo0---- > import Music.Theory.Duration.CT--- > import Music.Theory.Time.Seq--- > let ct = CT 2 [(1,[(3,8),(2,4)])] [(1,'a')] [(((1,0),T.None),60)] undefined--- > ct_measures ct-ct_measures :: CT -> [T.Dseq Rational CT_Node]-ct_measures (CT n ts mk tm _) =-    let f msg sq = let (m,v) = unzip sq-                   in if m == [1 .. n]-                      then v-                      else error (show ("ct_measures",msg,sq,m,v,n))-        msr = zip4-              (f "ts" (zip [1..] (ct_rq n ts)))-              (f "mk" (ct_mark_seq n mk))-              (f "pre-mk" (ct_pre_mark_seq n mk))-              (f "dv" (ct_dv_seq n ts))-    in map (ct_measure (ct_tempo_lseq_rq (ct_mdv_seq n ts) tm)) msr--ct_dseq' :: CT -> T.Dseq Rational CT_Node-ct_dseq' = concat . ct_measures--ct_dseq :: CT -> T.Dseq Double CT_Node-ct_dseq = T.dseq_tmap fromRational . ct_dseq'---- * Indirect--ct_rq_measure :: [[T.RQ]] -> T.RQ -> Maybe Measure-ct_rq_measure sq rq = fmap fst (find ((rq `elem`) . snd) (zip [1..] sq))--ct_rq_mp :: [[T.RQ]] -> T.RQ -> Maybe (Measure,Pulse)-ct_rq_mp sq rq =-    let f (m,l) = (m,fromMaybe (error "ct_rq_mp: ix") (findIndex (== rq) l) + 1)-    in fmap f (find ((rq `elem`) . snd) (zip [1..] sq))--ct_rq_mp_err :: [[T.RQ]] -> T.RQ -> (Measure, Pulse)-ct_rq_mp_err sq = fromMaybe (error "ct_rq_mp") . ct_rq_mp sq--ct_mp_to_rq :: [[T.RQ]] -> [((Measure,Pulse),t)] -> [(T.RQ,t)]-ct_mp_to_rq sq = map (\(mp,c) -> (ct_mp_lookup sq mp,c))
+ Music/Theory/Duration/ClickTrack.hs view
@@ -0,0 +1,216 @@+-- | Functions to generate a click track from a metric structure.+module Music.Theory.Duration.ClickTrack where++import Data.Bifunctor {- base -}+import Data.Function {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Music.Theory.List as List {- hmt-base -}++import qualified Music.Theory.Duration.Rq as T {- hmt -}+import qualified Music.Theory.Time_Signature as T {- hmt -}+import qualified Music.Theory.Time.Seq as T {- hmt -}++-- | 1-indexed.+type Measure = Int++-- | 1-indexed.+type Pulse = Int++-- | Measures given as 'T.Rq' divisions, Mdv abbreviates measure divisions.+type Mdv = [[T.Rq]]++{- | Absolute 'T.Rq' locations grouped in measures.+     mrq abbreviates measure rational quarter-notes.+     Locations are zero-indexed.+-}+type Mrq = [[T.Rq]]++{- | Transform Mdv to Mrq.++> mdv_to_mrq [[1,2,1],[3,2,1]] == [[0,1,3],[4,7,9]]+-}+mdv_to_mrq :: Mdv -> Mrq+mdv_to_mrq = snd . mapAccumL List.dx_d' 0++{- | Lookup function for ('Measure','Pulse') indexed structure.+     mp abbreviates Measure Pulse.+-}+mp_lookup_err :: [[t]] -> (Measure,Pulse) -> t+mp_lookup_err sq (m,p) =+    if m < 1 || p < 1+    then error (show ("mp_lookup_err: one indexed?",m,p))+    else (sq !! (m - 1)) !! (p - 1)++-- | Comparison for ('Measure','Pulse') indices.+mp_compare :: (Measure,Pulse) -> (Measure,Pulse) -> Ordering+mp_compare = List.two_stage_compare (compare `on` fst) (compare `on` snd)++-- * Ct++{- | Latch measures (ie. make measures contiguous, hold previous value).+     Arguments are the number of measures and the default (intial) value.++> unzip (ct_ext 10 'a' [(3,'b'),(8,'c')]) == ([1..10],"aabbbbbccc")+-}+ct_ext :: Int -> t -> T.Tseq Measure t -> T.Tseq Measure t+ct_ext n def sq = T.tseq_latch def sq [1 .. n]++-- | Variant that requires a value at measure one (first measure).+ct_ext1 :: Int -> T.Tseq Measure t -> T.Tseq Measure t+ct_ext1 n sq =+    case sq of+      (1,e) : sq' -> ct_ext n e sq'+      _ -> error "ct_ext1"++-- | 'T.rts_divisions' of 'ct_ext1'.+ct_dv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [(Measure,[[T.Rq]])]+ct_dv_seq n ts = map (fmap T.rts_divisions) (ct_ext1 n ts)++-- | 'ct_dv_seq' without measures numbers (which are 1..n)+ct_mdv_seq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.Rq]]+ct_mdv_seq n = map (concat . snd) . ct_dv_seq n++-- | 'mdv_to_mrq' of 'ct_mdv_seq'.+ct_rq :: Int -> T.Tseq Measure T.Rational_Time_Signature -> [[T.Rq]]+ct_rq n ts = mdv_to_mrq (ct_mdv_seq n ts)++ct_mp_lookup :: [[T.Rq]] -> (Measure,Pulse) -> T.Rq+ct_mp_lookup = mp_lookup_err . mdv_to_mrq++ct_m_to_rq :: [[T.Rq]] -> [(Measure,t)] -> [(T.Rq,t)]+ct_m_to_rq sq = map (\(m,c) -> (ct_mp_lookup sq (m,1),c))++-- | Latch rehearsal mark sequence, only indicating marks.  Initial mark is @.@.+--+-- > ct_mark_seq 2 [] == [(1,Just '.'),(2,Nothing)]+--+-- > let r = [(1,Just '.'),(3,Just 'A'),(8,Just 'B')]+-- > in filter (isJust . snd) (ct_mark_seq 10 [(3,'A'),(8,'B')]) == r+ct_mark_seq :: Int -> T.Tseq Measure Char -> T.Tseq Measure (Maybe Char)+ct_mark_seq n mk = T.seq_changed (ct_ext n '.' mk)++-- | Indicate measures prior to marks.+--+-- > ct_pre_mark [] == []+-- > ct_pre_mark [(1,'A')] == []+-- > ct_pre_mark [(3,'A'),(8,'B')] == [(2,Just ()),(7,Just ())]+ct_pre_mark :: [(Measure,a)] -> [(Measure,Maybe ())]+ct_pre_mark = mapMaybe (\(m,_) -> if m <= 1 then Nothing else Just (m - 1,Just ()))++-- | Contiguous pre-mark sequence.+--+-- > ct_pre_mark_seq 1 [(1,'A')] == [(1,Nothing)]+-- > ct_pre_mark_seq 10 [(3,'A'),(8,'B')]+ct_pre_mark_seq :: Measure -> T.Tseq Measure Char -> T.Tseq Measure (Maybe ())+ct_pre_mark_seq n mk =+    let pre = ct_pre_mark mk+    in T.tseq_merge_resolve const pre (zip [1 .. n] (repeat Nothing))++ct_tempo_lseq_rq :: [[T.Rq]] -> T.Lseq (Measure,Pulse) T.Rq -> T.Lseq T.Rq T.Rq+ct_tempo_lseq_rq sq = T.lseq_tmap (ct_mp_lookup sq)++-- | Interpolating lookup of tempo sequence ('T.lseq_lookup_err').+ct_tempo_at :: T.Lseq T.Rq T.Rq -> T.Rq -> Rational+ct_tempo_at = T.lseq_lookup_err compare++-- | Types of nodes.+data Ct_Node = Ct_Mark T.Rq -- ^ The start of a measure with a rehearsal mark.+             | Ct_Start T.Rq -- ^ The start of a regular measure.+             | Ct_Normal T.Rq -- ^ A regular pulse.+             | Ct_Edge T.Rq -- ^ The start of a pulse group within a measure.+             | Ct_Pre T.Rq -- ^ A regular pulse in a measure prior to a rehearsal mark.+             | Ct_End -- ^ The end of the track.+               deriving (Eq,Show)++-- | Lead-in of @(pulse,tempo,count)@.+ct_leadin :: (T.Rq,Double,Int) -> T.Dseq Double Ct_Node+ct_leadin (du,tm,n) = replicate n (realToFrac du * (60 / tm),Ct_Normal du)++-- | Prepend initial element to start of list.+--+-- > delay1 "abc" == "aabc"+delay1 :: [a] -> [a]+delay1 l =+    case l of+      [] -> error "delay1: []"+      e:_ -> e : l++{- | Generate Ct measure.+     Calculates durations of events considering only the tempo at the start of the event.+     To be correct it should consider the tempo envelope through the event.+-}+ct_measure:: T.Lseq T.Rq T.Rq -> ([T.Rq],Maybe Char,Maybe (),[[T.Rq]]) -> [(Rational,Ct_Node)]+ct_measure sq (mrq,mk,pr,dv) =+    let dv' = concatMap (zip [1::Int ..]) dv+        f (p,rq,(g,du)) =+            let nm = if p == 1+                     then case mk of+                            Nothing -> Ct_Start du+                            Just _ -> Ct_Mark du+                     else if pr == Just ()+                          then Ct_Pre du+                          else if g == 1 then Ct_Edge du else Ct_Normal du+            in (du * (60 / ct_tempo_at sq rq),nm)+    in map f (zip3 [1::Int ..] mrq dv')++-- | Click track definition.+data Ct =+  Ct+  {ct_len :: Int+  ,ct_ts :: [(Measure,T.Rational_Time_Signature)]+  ,ct_mark :: [(Measure,Char)]+  ,ct_tempo :: T.Lseq (Measure,Pulse) T.Rq+  ,ct_count :: (T.Rq,Int)}+  deriving Show++-- | Initial tempo, if given.+ct_tempo0 :: Ct -> Maybe T.Rq+ct_tempo0 ct =+    case ct_tempo ct of+      (((1,1),_),n):_ -> Just n+      _ -> Nothing++-- | Erroring variant.+ct_tempo0_err :: Ct -> T.Rq+ct_tempo0_err = fromMaybe (error "ct_tempo0") . ct_tempo0++-- > import Music.Theory.Duration.Ct+-- > import Music.Theory.Time.Seq+-- > let ct = CT 2 [(1,[(3,8),(2,4)])] [(1,'a')] [(((1,1),T.None),60)] undefined+-- > ct_measures ct+ct_measures :: Ct -> [T.Dseq Rational Ct_Node]+ct_measures (Ct n ts mk tm _) =+    let f msg sq = let (m,v) = unzip sq+                   in if m == [1 .. n]+                      then v+                      else error (show ("ct_measures",msg,sq,m,v,n))+        msr = zip4+              (f "ts" (zip [1..] (ct_rq n ts)))+              (f "mk" (ct_mark_seq n mk))+              (f "pre-mk" (ct_pre_mark_seq n mk))+              (f "dv" (ct_dv_seq n ts))+    in map (ct_measure (ct_tempo_lseq_rq (ct_mdv_seq n ts) tm)) msr++ct_dseq' :: Ct -> T.Dseq Rational Ct_Node+ct_dseq' = concat . ct_measures++ct_dseq :: Ct -> T.Dseq Double Ct_Node+ct_dseq = T.dseq_tmap fromRational . ct_dseq'++-- * Indirect++ct_rq_measure :: [[T.Rq]] -> T.Rq -> Maybe Measure+ct_rq_measure sq rq = fmap fst (find ((rq `elem`) . snd) (zip [1..] sq))++ct_rq_mp :: [[T.Rq]] -> T.Rq -> Maybe (Measure,Pulse)+ct_rq_mp sq rq =+    let f (m,l) = (m,fromMaybe (error "ct_rq_mp: ix") (elemIndex rq l) + 1)+    in fmap f (find ((rq `elem`) . snd) (zip [1..] sq))++ct_rq_mp_err :: [[T.Rq]] -> T.Rq -> (Measure, Pulse)+ct_rq_mp_err sq = fromMaybe (error "ct_rq_mp") . ct_rq_mp sq++ct_mp_to_rq :: [[T.Rq]] -> [((Measure,Pulse),t)] -> [(T.Rq,t)]+ct_mp_to_rq sq = map (first (ct_mp_lookup sq))
+ Music/Theory/Duration/Hollos2014.hs view
@@ -0,0 +1,104 @@+-- | "Creating Rhythms" by Stefan Hollos and J. Richard Hollos+--    <http://abrazol.com/books/rhythm1/software.html>+module Music.Theory.Duration.Hollos2014 where++import Data.List {- base -}++import Music.Theory.List {- hmt-base -}++import Music.Theory.Permutations.List {- hmt -}+import Music.Theory.Set.List {- hmt -}++-- | Donald Knuth, Art of Computer Programming, Algorithm H+--   <http://www-cs-faculty.stanford.edu/~knuth/fasc3b.ps.gz>+--+-- > partm 3 6 == [[1,1,4],[2,1,3],[2,2,2]]+partm :: (Num a, Ord a) => a -> a -> [[a]]+partm i j =+  let f t m n =+        if m == 1 && t == n+        then [[t]]+        else if n < m || n < 1 || m < 1 || t < 1+             then []+        else [reverse (t : r) | r <- f t (m - 1) (n - t)] ++ (f (t - 1) m n)+  in f (j - i + 1) i j++-- | Generates all partitions of n.+--+-- > compUniq 4 == [[1,1,1,1],[1,1,2],[1,3],[2,2],[4]]+-- > compUniq 5 == [[1,1,1,1,1],[1,1,1,2],[1,1,3],[2,1,2],[1,4],[2,3],[5]]+part :: (Num a, Ord a, Enum a) => a -> [[a]]+part n = concatMap (\k -> partm k n) (reverse [1 .. n])++-- | Generates all partitions of n with parts in the set e.+--+-- > parta 8 [2,3] == [[2,2,2,2],[3,2,3]]+parta :: (Num a, Ord a, Enum a) => a -> [a] -> [[a]]+parta n e = filter (all (`elem` e)) (part n)++-- | Generate all compositions of n.+--+-- > comp 4 == [[1,1,1,1],[1,1,2],[1,2,1],[2,1,1],[1,3],[3,1],[2,2],[4]]+-- > length (comp 8) == 128+comp :: (Num a, Ord a, Enum a) => a -> [[a]]+comp = concatMap multiset_permutations . part++-- | Generates all compositions of n into k parts.+--+-- > compm 3 6 == [[1,1,4],[1,4,1],[4,1,1],[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1],[2,2,2]]+-- > length (compm 5 16) == 1365+compm :: (Ord a, Num a) => a -> a -> [[a]]+compm k = concatMap multiset_permutations . partm k++-- | Generates all compositions of n with parts in the set (p1 p2 ... pk).+--+-- > compa 8 [3,4,5,6] == [[3,5],[5,3],[4,4]]+compa :: (Num a, Ord a, Enum a) => a -> [a] -> [[a]]+compa n e = filter (all (`elem` e)) (comp n)++-- | Generates all compositions of n with m parts in the set (p1 p2 ... pk).+--+-- > compam 4 16 [3,4,5]+compam :: (Num a, Ord a, Enum a) => a -> a -> [a] -> [[a]]+compam k n e = filter (all (`elem` e)) (compm k n)++-- | Generates all binary necklaces of length n.  <http://combos.org/necklace>+--+-- > neck 5 == [[1,1,1,1,1],[1,1,1,1,0],[1,1,0,1,0],[1,1,1,0,0],[1,0,1,0,0],[1,1,0,0,0],[1,0,0,0,0],[0,0,0,0,0]]+neck :: (Ord t, Num t) => Int -> [[t]]+neck n = concatMap multiset_cycles [replicate i 0 ++ replicate (n - i) 1 | i <- [0 .. n]]++-- | Generates all binary necklaces of length n with m ones.+--+-- > neckm 8 2 == [[1,0,0,0,1,0,0,0],[1,0,0,1,0,0,0,0],[1,0,1,0,0,0,0,0],[1,1,0,0,0,0,0,0]]+neckm :: (Num a, Ord a) => Int -> Int -> [[a]]+neckm n m = filter ((== m) . length . filter (== 1)) (neck n)++-- | Part is the length of a substring 10...0 composing the necklace.+--   For example the necklace 10100 has parts of size 2 and 3.+--+-- > necklaceParts [1,0,1,0,0] == [2,3]+-- > necklaceParts [0,0,0,0,0,0,0,0] == []+necklaceParts :: (Eq a, Num a) => [a] -> [Int]+necklaceParts l = d_dx (findIndices (== 1) l ++ [length l])++necklaceWithParts :: (Eq a, Num a) => [Int] -> [a] -> Bool+necklaceWithParts e l =+  let p = necklaceParts l+  in not (null p) && all (`elem` e) p++-- | Generates all binary necklaces of length n with parts in e.+--+-- > necka 8 [2,3,4] == [[1,0,1,0,1,0,1,0],[1,0,1,0,0,1,0,0],[1,0,1,0,1,0,0,0],[1,0,0,0,1,0,0,0]]+necka :: (Num a, Ord a) => Int -> [Int] -> [[a]]+necka n e = filter (necklaceWithParts e) (neck n)++-- | Generates all binary necklaces of length n with m ones and parts in e.+neckam :: (Num a, Ord a) => Int -> Int -> [Int] -> [[a]]+neckam n m e = filter (necklaceWithParts e) (neckm n m)++-- | Generates all permutations of the non-negative integers in the set.+--+-- > permi [1,2,3] == [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]+permi :: [a] -> [[a]]+permi = permutations_l
Music/Theory/Duration/Name.hs view
@@ -1,7 +1,7 @@ -- | Names for common music notation durations. module Music.Theory.Duration.Name where -import Music.Theory.Duration+import Music.Theory.Duration {- hmt -}  -- * Constants
Music/Theory/Duration/Name/Abbreviation.hs view
@@ -1,4 +1,4 @@--- | Abbreviated names for 'Duration' values when written as literals.+-- | Abbreviated names for 'Duration' values when written as Haskell literals. -- There are /letter/ names where 'w' is 'whole_note' and so on, and -- /numerical/ names where '_4' is 'quarter_note' and so on.  In both -- cases a @'@ extension means a @dot@ so that 'e''' is a double
− Music/Theory/Duration/RQ.hs 
@@ -1,193 +0,0 @@--- | Rational quarter-note notation for durations.-module Music.Theory.Duration.RQ where--import Data.Function {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}-import Data.Ratio {- base -}--import Music.Theory.Duration {- hmt -}---- | Rational Quarter-Note-type RQ = Rational---- > rq_duration_tbl 2-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--- this could handle tuplets directly since, for instance, a @3:2@--- dotted note will be of the same duration as a plain undotted note.------ > rq_to_duration (3/4) == Just dotted_eighth_note-rq_to_duration :: RQ -> Maybe Duration-rq_to_duration x = lookup x (rq_duration_tbl 2)---- | Is 'RQ' a /cmn/ duration.------ > map rq_is_cmn [1/4,1/5,1/8,3/32] == [True,False,True,False]-rq_is_cmn :: RQ -> Bool-rq_is_cmn = isJust . rq_to_duration---- | Variant of 'rq_to_duration' with error message.-rq_to_duration_err :: Show a => a -> RQ -> Duration-rq_to_duration_err msg n =-    let err = error ("rq_to_duration:" ++ show (msg,n))-    in fromMaybe err (rq_to_duration n)---- | 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 :: Division -> RQ-whole_note_division_to_rq x =-    let f = (* 4) . recip . (%1)-    in case x of-         0 -> 8-         -1 -> 16-         _ -> f x---- | Apply dots to an 'RQ' duration.------ > 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)---- | Convert 'Duration' to 'RQ' value, see 'rq_to_duration' for--- partial inverse.------ > let d = [half_note,dotted_quarter_note,dotted_whole_note]--- > in map duration_to_rq d == [2,3/2,6]-duration_to_rq :: Duration -> RQ-duration_to_rq (Duration n d m) =-    let x = whole_note_division_to_rq n-    in rq_apply_dots x d * m---- | 'compare' function for 'Duration' via 'duration_to_rq'.------ > half_note `duration_compare_rq` quarter_note == GT-duration_compare_rq :: Duration -> Duration -> Ordering-duration_compare_rq = compare `on` duration_to_rq---- | 'RQ' modulo.------ > map (rq_mod (5/2)) [3/2,3/4,5/2] == [1,1/4,0]-rq_mod :: RQ -> RQ -> RQ-rq_mod i j-    | i == j = 0-    | i < 0 = rq_mod (i + j) j-    | i > j = rq_mod (i - j) j-    | otherwise = i---- | Is /p/ divisible by /q/, ie. is the 'denominator' of @p/q@ '==' @1@.------ > map (rq_divisible_by (3%2)) [1%2,1%3] == [True,False]-rq_divisible_by :: RQ -> RQ -> Bool-rq_divisible_by i j = denominator (i / j) == 1---- | Is 'RQ' a whole number (ie. is 'denominator' '==' @1@.------ > map rq_is_integral [1,3/2,2] == [True,False,True]-rq_is_integral :: RQ -> Bool-rq_is_integral = (== 1) . denominator---- | Return 'numerator' of 'RQ' if 'denominator' '==' @1@.------ > map rq_integral [1,3/2,2] == [Just 1,Nothing,Just 2]-rq_integral :: RQ -> Maybe Integer-rq_integral n = if rq_is_integral n then Just (numerator n) else Nothing---- | Derive the tuplet structure of a set of 'RQ' values.------ > rq_derive_tuplet_plain [1/2] == Nothing--- > rq_derive_tuplet_plain [1/2,1/2] == Nothing--- > rq_derive_tuplet_plain [1/4,1/4] == Nothing--- > rq_derive_tuplet_plain [1/3,2/3] == Just (3,2)--- > rq_derive_tuplet_plain [1/2,1/3,1/6] == Just (6,4)--- > rq_derive_tuplet_plain [1/3,1/6] == Just (6,4)--- > rq_derive_tuplet_plain [2/5,3/5] == Just (5,4)--- > rq_derive_tuplet_plain [1/3,1/6,2/5,1/10] == Just (30,16)------ > map rq_derive_tuplet_plain [[1/3,1/6],[2/5,1/10]] == [Just (6,4)--- >                                                      ,Just (10,8)]-rq_derive_tuplet_plain :: [RQ] -> Maybe (Integer,Integer)-rq_derive_tuplet_plain x =-    let i = foldl lcm 1 (map denominator x)-        j = let z = iterate (* 2) 2-            in fromJust (find (>= i) z) `div` 2-    in if i `rem` j == 0 then Nothing else Just (i,j)---- | Derive the tuplet structure of a set of 'RQ' values.------ > rq_derive_tuplet [1/4,1/8,1/8] == Nothing--- > rq_derive_tuplet [1/3,2/3] == Just (3,2)--- > rq_derive_tuplet [1/2,1/3,1/6] == Just (3,2)--- > rq_derive_tuplet [2/5,3/5] == Just (5,4)--- > rq_derive_tuplet [1/3,1/6,2/5,1/10] == Just (15,8)-rq_derive_tuplet :: [RQ] -> Maybe (Integer,Integer)-rq_derive_tuplet =-    let f (i,j) = let k = i % j-                  in (numerator k,denominator k)-    in fmap f . rq_derive_tuplet_plain---- | Remove tuplet multiplier from value, ie. to give notated--- duration.  This seems odd but is neccessary to avoid ambiguity.--- Ie. is @1@ a quarter note or a @3:2@ tuplet dotted-quarter-note etc.------ > map (rq_un_tuplet (3,2)) [1,2/3,1/2,1/3] == [3/2,1,3/4,1/2]-rq_un_tuplet :: (Integer,Integer) -> RQ -> RQ-rq_un_tuplet (i,j) x = x * (i % j)---- | If an 'RQ' duration is un-representable by a single /cmn/--- duration, give tied notation.------ > catMaybes (map rq_to_cmn [1..9]) == [(4,1),(4,3),(8,1)]------ > map rq_to_cmn [5/4,5/8] == [Just (1,1/4),Just (1/2,1/8)]-rq_to_cmn :: RQ -> Maybe (RQ,RQ)-rq_to_cmn x =-    let (i,j) = (numerator x,denominator x)-        k = case i of-              5 -> Just (4,1)-              7 -> Just (4,3)-              9 -> Just (8,1)-              _ -> Nothing-        f (n,m) = (n%j,m%j)-    in fmap f k---- | Predicate to determine if a segment can be notated either without--- a tuplet or with a single tuplet.------ > rq_can_notate [1/2,1/4,1/4] == True--- > rq_can_notate [1/3,1/6] == True--- > rq_can_notate [2/5,1/10] == True--- > rq_can_notate [1/3,1/6,2/5,1/10] == False--- > rq_can_notate [4/7,1/7,6/7,3/7] == True--- > rq_can_notate [4/7,1/7,2/7] == True-rq_can_notate :: [RQ] -> Bool-rq_can_notate x =-    let x' = case rq_derive_tuplet x of-               Nothing -> x-               Just t -> map (rq_un_tuplet t) x-    in all rq_is_cmn x'---- * TIME---- | Duration in seconds of RQ given ppm------   ppm = pulses-per-minute, rq = rational-quarter-note------ > map (\sd -> rq_to_seconds_ppm (90 * sd) 1) [1,2,4,8,16] == [2/3,1/3,1/6,1/12,1/24]--- > map (rq_to_seconds_ppm 90) [1,2,3,4] == [2/3,1 + 1/3,2,2 + 2/3]--- > map (rq_to_seconds_ppm 90) [0::RQ,1,1 + 1/2,1 + 3/4,1 + 7/8,2]-rq_to_seconds_ppm :: Fractional a => a -> a -> a-rq_to_seconds_ppm ppm rq = rq * (60 / ppm)---- | PPM given that /rq/ has duration /x/, ie. inverse of 'rq_to_seconds'------ > map (rq_to_ppm 1) [0.4,0.5,0.8,1,1.5,2] == [150,120,75,60,40,30]--- > map (\ppm -> rq_to_seconds ppm 1) [150,120,75,60,40,30] == [0.4,0.5,0.8,1,1.5,2]-rq_to_ppm :: Fractional a => a -> a -> a-rq_to_ppm rq x = (rq / x) * 60-
− Music/Theory/Duration/RQ/Division.hs 
@@ -1,91 +0,0 @@--- | 'RQ' sub-divisions.-module Music.Theory.Duration.RQ.Division where--import Data.List.Split {- split -}-import Data.Ratio--import Music.Theory.Duration.RQ-import Music.Theory.Duration.RQ.Tied-import Music.Theory.List-import Music.Theory.Permutations.List---- | Divisions of /n/ 'RQ' into /i/ equal parts grouped as /j/.--- A quarter and eighth note triplet is written @(1,1,[2,1],False)@.-type RQ_Div = (Rational,Integer,[Integer],Tied_Right)---- | Variant of 'RQ_Div' where /n/ is @1@.-type RQ1_Div = (Integer,[Integer],Tied_Right)---- | Lift 'RQ1_Div' to 'RQ_Div'.-rq1_div_to_rq_div :: RQ1_Div -> RQ_Div-rq1_div_to_rq_div (i,j,k) = (1,i,j,k)---- | Verify that grouping /j/ sums to the divisor /i/.-rq_div_verify :: RQ_Div -> Bool-rq_div_verify (_,n,m,_) = n == sum m--rq_div_mm_verify :: Int -> [RQ_Div] -> [(Integer,[RQ])]-rq_div_mm_verify n x =-    let q = map (sum . fst . rq_div_to_rq_set_t) x-    in zip [1..] (chunksOf n q)---- | Translate from 'RQ_Div' to a sequence of 'RQ' values.------ > rq_div_to_rq_set_t (1,5,[1,3,1],True) == ([1/5,3/5,1/5],True)--- > rq_div_to_rq_set_t (1/2,6,[3,1,2],False) == ([1/4,1/12,1/6],False)-rq_div_to_rq_set_t :: RQ_Div -> ([RQ],Tied_Right)-rq_div_to_rq_set_t (n,k,d,t) =-    let q = map ((* n) . (% k)) d-    in (q,t)---- | Translate from result of 'rq_div_to_rq_set_t' to seqeunce of 'RQ_T'.------ > rq_set_t_to_rqt ([1/5,3/5,1/5],True) == [(1/5,_f),(3/5,_f),(1/5,_t)]-rq_set_t_to_rqt :: ([RQ],Tied_Right) -> [RQ_T]-rq_set_t_to_rqt (x,t) = at_last (\i -> (i,False)) (\i -> (i,t)) x---- | Transform sequence of 'RQ_Div' into sequence of 'RQ', discarding--- any final tie.------ > let q = [(1,5,[1,3,1],True),(1/2,6,[3,1,2],True)]--- > in rq_div_seq_rq q == [1/5,3/5,9/20,1/12,1/6]-rq_div_seq_rq :: [RQ_Div] -> [RQ]-rq_div_seq_rq =-    let f i qq = case qq of-                  [] -> maybe [] return i-                  q:qq' -> let (r,t) = rq_div_to_rq_set_t q-                               r' = maybe r (\j -> at_head (+ j) id r) i-                           in if t-                              then let (r'',i') = separate_last r'-                                   in r'' ++ f (Just i') qq'-                              else r' ++ f Nothing qq'-    in f Nothing---- | Partitions of an 'Integral' that sum to /n/.  This includes the--- two 'trivial paritions, into a set /n/ @1@, and a set of @1@ /n/.------ > partitions_sum 4 == [[1,1,1,1],[2,1,1],[2,2],[3,1],[4]]------ > map (length . partitions_sum) [9..15] == [30,42,56,77,101,135,176]-partitions_sum :: Integral i => i -> [[i]]-partitions_sum n =-    let f p = if null p then 0 else head p-    in case n of-         0 -> [[]]-         _ -> [x:y | x <- [1..n], y <- partitions_sum (n - x), x >= f y]---- | The 'multiset_permutations' of 'partitions_sum'.------ > map (length . partitions_sum_p) [9..12] == [256,512,1024,2048]-partitions_sum_p :: Integral i => i -> [[i]]-partitions_sum_p = concatMap multiset_permutations . partitions_sum---- | The set of all 'RQ1_Div' that sum to /n/, a variant on--- 'partitions_sum_p'.------ > map (length . rq1_div_univ) [3..5] == [8,16,32]--- > map (length . rq1_div_univ) [9..12] == [512,1024,2048,4096]-rq1_div_univ :: Integer -> [RQ1_Div]-rq1_div_univ n =-    let f l = [(n,l,k) | k <- [False,True]]-    in concatMap f (partitions_sum_p n)
− Music/Theory/Duration/RQ/Tied.hs 
@@ -1,91 +0,0 @@--- | 'RQ' values with /tie right/ qualifier.-module Music.Theory.Duration.RQ.Tied where--import Data.Maybe-import Music.Theory.Duration.Annotation-import Music.Theory.Duration.RQ-import Music.Theory.List---- | Boolean.-type Tied_Right = Bool---- | 'RQ' with /tie right/.-type RQ_T = (RQ,Tied_Right)---- | Construct 'RQ_T'.-rqt :: Tied_Right -> RQ -> RQ_T-rqt t d = (d,t)---- | 'RQ' field of 'RQ_T'.-rqt_rq :: RQ_T -> RQ-rqt_rq = fst---- | 'Tied' field of 'RQ_T'.-rqt_tied :: RQ_T -> Tied_Right-rqt_tied = snd---- | Is 'RQ_T' tied right.-is_tied_right :: RQ_T -> Bool-is_tied_right = snd---- | 'RQ_T' variant of 'rq_un_tuplet'.------ > rqt_un_tuplet (3,2) (1,T) == (3/2,T)------ > let f = rqt_un_tuplet (7,4)--- > in map f [(2/7,F),(4/7,T),(1/7,F)] == [(1/2,F),(1,T),(1/4,F)]-rqt_un_tuplet :: (Integer,Integer) -> RQ_T -> RQ_T-rqt_un_tuplet i (d,t) = (rq_un_tuplet i d,t)---- | Transform 'RQ' to untied 'RQ_T'.------ > rq_rqt 3 == (3,F)-rq_rqt :: RQ -> RQ_T-rq_rqt n = (n,False)---- | Tie last element only of list of 'RQ'.------ > rq_tie_last [1,2,3] == [(1,F),(2,F),(3,T)]-rq_tie_last :: [RQ] -> [RQ_T]-rq_tie_last = at_last rq_rqt (\d -> (d,True))---- | Transform a list of 'RQ_T' to a list of 'Duration_A'.  The flag--- indicates if the initial value is tied left.------ > rqt_to_duration_a False [(1,T),(1/4,T),(3/4,F)]-rqt_to_duration_a :: Bool -> [RQ_T] -> [Duration_A]-rqt_to_duration_a z x =-    let rt = map is_tied_right x-        lt = z : rt-        f p e = if p then Just e else Nothing-        g r l = catMaybes [f r Tie_Right,f l Tie_Left]-        h = rq_to_duration_err (show ("rqt_to_duration_a",z,x)) . rqt_rq-    in zip (map h x) (zipWith g rt lt)---- | 'RQ_T' variant of 'rq_can_notate'.-rqt_can_notate :: [RQ_T] -> Bool-rqt_can_notate = rq_can_notate . map rqt_rq---- | 'RQ_T' variant of 'rq_to_cmn'.------ > rqt_to_cmn (5,T) == Just ((4,T),(1,T))--- > rqt_to_cmn (5/4,T) == Just ((1,T),(1/4,T))--- > rqt_to_cmn (5/7,F) == Just ((4/7,T),(1/7,F))-rqt_to_cmn :: RQ_T -> Maybe (RQ_T,RQ_T)-rqt_to_cmn (k,t) =-    let f (i,j) = ((i,True),(j,t))-    in fmap f (rq_to_cmn k)---- | List variant of 'rqt_to_cmn'.------ > rqt_to_cmn_l (5,T) == [(4,T),(1,T)]-rqt_to_cmn_l :: RQ_T -> [RQ_T]-rqt_to_cmn_l x = maybe [x] (\(i,j) -> [i,j]) (rqt_to_cmn x)---- | 'concatMap' 'rqt_to_cmn_l'.------ > rqt_set_to_cmn [(1,T),(5/4,F)] == [(1,T),(1,T),(1/4,F)]------ > rqt_set_to_cmn [(1/5,True),(1/20,False),(1/2,False),(1/4,True)]-rqt_set_to_cmn :: [RQ_T] -> [RQ_T]-rqt_set_to_cmn = concatMap rqt_to_cmn_l
+ Music/Theory/Duration/Rq.hs view
@@ -0,0 +1,239 @@+-- | Rational quarter-note notation for durations.+module Music.Theory.Duration.Rq where++import Data.Function {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -}++import qualified Music.Theory.List as T {- hmt-base -}++import Music.Theory.Duration {- hmt -}++-- | Rational Quarter-Note+type Rq = Rational++{- | Table mapping tuple Rq values to Durations.+     Only has cases where the duration can be expressed without a tie.+     Currently has entries for 3-,5-,6- and 7-tuplets.++> all (\(i,j) -> i == duration_to_rq j) rq_tuplet_duration_table == True+-}+rq_tuplet_duration_table :: [(Rq, Duration)]+rq_tuplet_duration_table =+  [(1/3,Duration 8 0 (2/3))+  ,(2/3,Duration 4 0 (2/3))+  ,(1/5,Duration 16 0 (4/5))+  ,(2/5,Duration 8 0 (4/5))+  ,(3/5,Duration 8 1 (4/5))+  ,(4/5,Duration 4 0 (4/5))+  ,(1/6,Duration 16 0 (2/3))+  ,(1/7,Duration 16 0 (4/7))+  ,(2/7,Duration 8 0 (4/7))+  ,(3/7,Duration 8 1 (4/7))+  ,(4/7,Duration 4 0 (4/7))+  ,(6/7,Duration 4 1 (4/7))+  ]++{- | Lookup rq_tuplet_duration_tbl.++> rq_tuplet_to_duration (1/3) == Just (Duration 8 0 (2/3))+-}+rq_tuplet_to_duration :: Rq -> Maybe Duration+rq_tuplet_to_duration x = lookup x rq_tuplet_duration_table++{- | Make table of (Rq,Duration) associations.+     Only lists durations with a multiplier of 1.++> map (length . rq_plain_duration_tbl) [1,2,3] == [20,30,40]+> map (multiplier . snd) (rq_plain_duration_tbl 1) == replicate 20 1+-}+rq_plain_duration_tbl :: Dots -> [(Rq,Duration)]+rq_plain_duration_tbl k = map (\d -> (duration_to_rq d,d)) (duration_set k)++rq_plain_to_duration :: Dots -> Rq -> Maybe Duration+rq_plain_to_duration k x = lookup x (rq_plain_duration_tbl k)++rq_plain_to_duration_err :: Dots -> Rq -> Duration+rq_plain_to_duration_err k x = T.lookup_err x (rq_plain_duration_tbl k)++{- | Rational quarter note to duration value.+     Lookup composite plain (hence dots) and tuplet tables.+     It is a mistake to hope this could handle tuplets directly in a general sense.+     For instance, a @3:2@ dotted note is the same duration as a plain undotted note.+     However it does give durations for simple notations of simple tuplet values.++> rq_to_duration 2 (3/4) == Just (Duration 8 1 1) -- dotted_eighth_note+> rq_to_duration 2 (1/3) == Just (Duration 8 0 (2/3))+-}+rq_to_duration :: Dots -> Rq -> Maybe Duration+rq_to_duration k x = lookup x (rq_tuplet_duration_table ++ rq_plain_duration_tbl k)++-- | Variant of 'rq_to_duration' with error message.+rq_to_duration_err :: Show a => a -> Dots -> Rq -> Duration+rq_to_duration_err msg k n =+    let err = error ("rq_to_duration:" ++ show (msg,n))+    in fromMaybe err (rq_to_duration k n)++-- | Is 'Rq' a /cmn/ duration (ie. rq_plain_to_duration)+--+-- > map (rq_is_cmn 2) [1/4,1/5,1/8,3/32] == [True,False,True,True]+rq_is_cmn :: Dots -> Rq -> Bool+rq_is_cmn k = isJust . rq_plain_to_duration k++-- | 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 :: Division -> Rq+whole_note_division_to_rq x =+    let f = (* 4) . recip . (% 1)+    in case x of+         0 -> 8+         -1 -> 16+         _ -> f x++-- | Apply dots to an 'Rq' duration.+--+-- > 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)++-- | Convert 'Duration' to 'Rq' value, see 'rq_to_duration' for partial inverse.+--+-- > let d = [Duration 2 0 1,Duration 4 1 1,Duration 1 1 1]+-- > map duration_to_rq d == [2,3/2,6] -- half_note,dotted_quarter_note,dotted_whole_note+duration_to_rq :: Duration -> Rq+duration_to_rq (Duration n d m) =+    let x = whole_note_division_to_rq n+    in rq_apply_dots x d * m++-- | 'compare' function for 'Duration' via 'duration_to_rq'.+--+-- > half_note `duration_compare_rq` quarter_note == GT+duration_compare_rq :: Duration -> Duration -> Ordering+duration_compare_rq = compare `on` duration_to_rq++-- | 'Rq' modulo.+--+-- > map (rq_mod (5/2)) [3/2,3/4,5/2] == [1,1/4,0]+rq_mod :: Rq -> Rq -> Rq+rq_mod i j+    | i == j = 0+    | i < 0 = rq_mod (i + j) j+    | i > j = rq_mod (i - j) j+    | otherwise = i++-- | Is /p/ divisible by /q/, ie. is the 'denominator' of @p/q@ '==' @1@.+--+-- > map (rq_divisible_by (3%2)) [1%2,1%3] == [True,False]+rq_divisible_by :: Rq -> Rq -> Bool+rq_divisible_by i j = denominator (i / j) == 1++-- | Is 'Rq' a whole number (ie. is 'denominator' '==' @1@.+--+-- > map rq_is_integral [1,3/2,2] == [True,False,True]+rq_is_integral :: Rq -> Bool+rq_is_integral = (== 1) . denominator++-- | Return 'numerator' of 'Rq' if 'denominator' '==' @1@.+--+-- > map rq_integral [1,3/2,2] == [Just 1,Nothing,Just 2]+rq_integral :: Rq -> Maybe Integer+rq_integral n = if rq_is_integral n then Just (numerator n) else Nothing++-- | Derive the tuplet structure of a set of 'Rq' values.+--+-- > rq_derive_tuplet_plain [1/2] == Nothing+-- > rq_derive_tuplet_plain [1/2,1/2] == Nothing+-- > rq_derive_tuplet_plain [1/4,1/4] == Nothing+-- > rq_derive_tuplet_plain [1/3,2/3] == Just (3,2)+-- > rq_derive_tuplet_plain [1/2,1/3,1/6] == Just (6,4)+-- > rq_derive_tuplet_plain [1/3,1/6] == Just (6,4)+-- > rq_derive_tuplet_plain [2/5,3/5] == Just (5,4)+-- > rq_derive_tuplet_plain [1/3,1/6,2/5,1/10] == Just (30,16)+--+-- > map rq_derive_tuplet_plain [[1/3,1/6],[2/5,1/10]] == [Just (6,4)+-- >                                                      ,Just (10,8)]+rq_derive_tuplet_plain :: [Rq] -> Maybe (Integer,Integer)+rq_derive_tuplet_plain x =+    let i = foldl lcm 1 (map denominator x)+        j = let z = iterate (* 2) 2+            in fromJust (find (>= i) z) `div` 2+    in if i `rem` j == 0 then Nothing else Just (i,j)++-- | Derive the tuplet structure of a set of 'Rq' values.+--+-- > rq_derive_tuplet [1/4,1/8,1/8] == Nothing+-- > rq_derive_tuplet [1/3,2/3] == Just (3,2)+-- > rq_derive_tuplet [1/2,1/3,1/6] == Just (3,2)+-- > rq_derive_tuplet [2/5,3/5] == Just (5,4)+-- > rq_derive_tuplet [1/3,1/6,2/5,1/10] == Just (15,8)+rq_derive_tuplet :: [Rq] -> Maybe (Integer,Integer)+rq_derive_tuplet =+    let f (i,j) = let k = i % j+                  in (numerator k,denominator k)+    in fmap f . rq_derive_tuplet_plain++-- | Remove tuplet multiplier from value, ie. to give notated+-- duration.  This seems odd but is neccessary to avoid ambiguity.+-- Ie. is @1@ a quarter note or a @3:2@ tuplet dotted-quarter-note etc.+--+-- > map (rq_un_tuplet (3,2)) [1,2/3,1/2,1/3] == [3/2,1,3/4,1/2]+rq_un_tuplet :: (Integer,Integer) -> Rq -> Rq+rq_un_tuplet (i,j) x = x * (i % j)++-- | If an 'Rq' duration is un-representable by a single /cmn/+-- duration, give tied notation.+--+-- > catMaybes (map rq_to_cmn [1..9]) == [(4,1),(4,3),(8,1)]+--+-- > map rq_to_cmn [5/4,5/8] == [Just (1,1/4),Just (1/2,1/8)]+rq_to_cmn :: Rq -> Maybe (Rq,Rq)+rq_to_cmn x =+    let (i,j) = (numerator x,denominator x)+        k = case i of+              5 -> Just (4,1)+              7 -> Just (4,3)+              9 -> Just (8,1)+              _ -> Nothing+        f (n,m) = (n%j,m%j)+    in fmap f k++{- | Predicate to determine if a segment can be notated+     either without a tuplet or with a single tuplet.++> rq_can_notate 2 [1/2,1/4,1/4] == True+> rq_can_notate 2 [1/3,1/6] == True+> rq_can_notate 2 [2/5,1/10] == True+> rq_can_notate 2 [1/3,1/6,2/5,1/10] == False+> rq_can_notate 2 [4/7,1/7,6/7,3/7] == True+> rq_can_notate 2 [4/7,1/7,2/7] == True+-}+rq_can_notate :: Dots -> [Rq] -> Bool+rq_can_notate k x =+    let x' = case rq_derive_tuplet x of+               Nothing -> x+               Just t -> map (rq_un_tuplet t) x+    in all (rq_is_cmn k) x'++-- * Time++-- | Duration in seconds of Rq given qpm+--+--   qpm = pulses-per-minute, rq = rational-quarter-note+--+-- > map (\sd -> rq_to_seconds_qpm (90 * sd) 1) [1,2,4,8,16] == [2/3,1/3,1/6,1/12,1/24]+-- > map (rq_to_seconds_qpm 90) [1,2,3,4] == [2/3,1 + 1/3,2,2 + 2/3]+-- > map (rq_to_seconds_qpm 90) [0::Rq,1,1 + 1/2,1 + 3/4,1 + 7/8,2] == [0,2/3,1,7/6,5/4,4/3]+rq_to_seconds_qpm :: Fractional a => a -> a -> a+rq_to_seconds_qpm qpm rq = rq * (60 / qpm)++-- | Qpm given that /rq/ has duration /x/, ie. inverse of 'rq_to_seconds_qpm'+--+-- > map (rq_to_qpm 1) [0.4,0.5,0.8,1,1.5,2] == [150,120,75,60,40,30]+-- > map (\qpm -> rq_to_seconds_qpm qpm 1) [150,120,75,60,40,30] == [0.4,0.5,0.8,1,1.5,2]+rq_to_qpm :: Fractional a => a -> a -> a+rq_to_qpm rq x = (rq / x) * 60+
+ Music/Theory/Duration/Rq/Division.hs view
@@ -0,0 +1,91 @@+-- | 'Rq' sub-divisions.+module Music.Theory.Duration.Rq.Division where++import Data.List.Split {- split -}+import Data.Ratio++import Music.Theory.Duration.Rq+import Music.Theory.Duration.Rq.Tied+import Music.Theory.List+import Music.Theory.Permutations.List++-- | Divisions of /n/ 'Rq' into /i/ equal parts grouped as /j/.+-- A quarter and eighth note triplet is written @(1,1,[2,1],False)@.+type Rq_Div = (Rational,Integer,[Integer],Tied_Right)++-- | Variant of 'Rq_Div' where /n/ is @1@.+type Rq1_Div = (Integer,[Integer],Tied_Right)++-- | Lift 'Rq1_Div' to 'Rq_Div'.+rq1_div_to_rq_div :: Rq1_Div -> Rq_Div+rq1_div_to_rq_div (i,j,k) = (1,i,j,k)++-- | Verify that grouping /j/ sums to the divisor /i/.+rq_div_verify :: Rq_Div -> Bool+rq_div_verify (_,n,m,_) = n == sum m++rq_div_mm_verify :: Int -> [Rq_Div] -> [(Integer,[Rq])]+rq_div_mm_verify n x =+    let q = map (sum . fst . rq_div_to_rq_set_t) x+    in zip [1..] (chunksOf n q)++-- | Translate from 'Rq_Div' to a sequence of 'Rq' values.+--+-- > rq_div_to_rq_set_t (1,5,[1,3,1],True) == ([1/5,3/5,1/5],True)+-- > rq_div_to_rq_set_t (1/2,6,[3,1,2],False) == ([1/4,1/12,1/6],False)+rq_div_to_rq_set_t :: Rq_Div -> ([Rq],Tied_Right)+rq_div_to_rq_set_t (n,k,d,t) =+    let q = map ((* n) . (% k)) d+    in (q,t)++-- | Translate from result of 'rq_div_to_rq_set_t' to seqeunce of 'Rq_Tied'.+--+-- > rq_set_t_to_rqt ([1/5,3/5,1/5],True) == [(1/5,_f),(3/5,_f),(1/5,_t)]+rq_set_t_to_rqt :: ([Rq],Tied_Right) -> [Rq_Tied]+rq_set_t_to_rqt (x,t) = at_last (\i -> (i,False)) (\i -> (i,t)) x++-- | Transform sequence of 'Rq_Div' into sequence of 'Rq', discarding+-- any final tie.+--+-- > let q = [(1,5,[1,3,1],True),(1/2,6,[3,1,2],True)]+-- > in rq_div_seq_rq q == [1/5,3/5,9/20,1/12,1/6]+rq_div_seq_rq :: [Rq_Div] -> [Rq]+rq_div_seq_rq =+    let f i qq = case qq of+                  [] -> maybe [] return i+                  q:qq' -> let (r,t) = rq_div_to_rq_set_t q+                               r' = maybe r (\j -> at_head (+ j) id r) i+                           in if t+                              then let (r'',i') = separate_last r'+                                   in r'' ++ f (Just i') qq'+                              else r' ++ f Nothing qq'+    in f Nothing++-- | Partitions of an 'Integral' that sum to /n/.  This includes the+-- two 'trivial paritions, into a set /n/ @1@, and a set of @1@ /n/.+--+-- > partitions_sum 4 == [[1,1,1,1],[2,1,1],[2,2],[3,1],[4]]+--+-- > map (length . partitions_sum) [9..15] == [30,42,56,77,101,135,176]+partitions_sum :: Integral i => i -> [[i]]+partitions_sum n =+    let f p = if null p then 0 else head p+    in case n of+         0 -> [[]]+         _ -> [x:y | x <- [1..n], y <- partitions_sum (n - x), x >= f y]++-- | The 'multiset_permutations' of 'partitions_sum'.+--+-- > map (length . partitions_sum_p) [9..12] == [256,512,1024,2048]+partitions_sum_p :: Integral i => i -> [[i]]+partitions_sum_p = concatMap multiset_permutations . partitions_sum++-- | The set of all 'Rq1_Div' that sum to /n/, a variant on+-- 'partitions_sum_p'.+--+-- > map (length . rq1_div_univ) [3..5] == [8,16,32]+-- > map (length . rq1_div_univ) [9..12] == [512,1024,2048,4096]+rq1_div_univ :: Integer -> [Rq1_Div]+rq1_div_univ n =+    let f l = [(n,l,k) | k <- [False,True]]+    in concatMap f (partitions_sum_p n)
+ Music/Theory/Duration/Rq/Tied.hs view
@@ -0,0 +1,101 @@+-- | 'Rq' values with /tie right/ qualifier.+module Music.Theory.Duration.Rq.Tied where++import Data.Maybe {- base -}++import Music.Theory.List {- hmt-base -}++import Music.Theory.Duration {- hmt -}+import qualified Music.Theory.Duration.Annotation as Annotation {- hmt -}+import Music.Theory.Duration.Rq {- hmt -}++-- | Boolean.+type Tied_Right = Bool++-- | 'Rq' with /tie right/.+type Rq_Tied = (Rq,Tied_Right)++-- | If Rq_Tied is not tied, get Rq.+rqt_to_rq :: Rq_Tied -> Maybe Rq+rqt_to_rq (rq,x) = if x then Nothing else Just rq++-- | Erroring variant of rqt_to_rq.+rqt_to_rq_err :: Rq_Tied -> Rq+rqt_to_rq_err = fromMaybe (error "rqt_to_rq") . rqt_to_rq++-- | Construct 'Rq_Tied'.+rqt :: Tied_Right -> Rq -> Rq_Tied+rqt t d = (d,t)++-- | 'Rq' field of 'Rq_Tied'.+rqt_rq :: Rq_Tied -> Rq+rqt_rq = fst++-- | 'Tied' field of 'Rq_Tied'.+rqt_tied :: Rq_Tied -> Tied_Right+rqt_tied = snd++-- | Is 'Rq_Tied' tied right.+is_tied_right :: Rq_Tied -> Bool+is_tied_right = snd++-- | 'Rq_Tied' variant of 'rq_un_tuplet'.+--+-- > rqt_un_tuplet (3,2) (1,T) == (3/2,T)+--+-- > let f = rqt_un_tuplet (7,4)+-- > in map f [(2/7,F),(4/7,T),(1/7,F)] == [(1/2,F),(1,T),(1/4,F)]+rqt_un_tuplet :: (Integer,Integer) -> Rq_Tied -> Rq_Tied+rqt_un_tuplet i (d,t) = (rq_un_tuplet i d,t)++-- | Transform 'Rq' to untied 'Rq_Tied'.+--+-- > rq_rqt 3 == (3,F)+rq_rqt :: Rq -> Rq_Tied+rq_rqt n = (n,False)++-- | Tie last element only of list of 'Rq'.+--+-- > rq_tie_last [1,2,3] == [(1,F),(2,F),(3,T)]+rq_tie_last :: [Rq] -> [Rq_Tied]+rq_tie_last = at_last rq_rqt (\d -> (d,True))++-- | Transform a list of 'Rq_Tied' to a list of 'Duration_A'.  The flag+-- indicates if the initial value is tied left.+--+-- > rqt_to_duration_a False [(1,T),(1/4,T),(3/4,F)]+rqt_to_duration_a :: Bool -> [Rq_Tied] -> [Annotation.Duration_A]+rqt_to_duration_a z x =+    let rt = map is_tied_right x+        lt = z : rt+        f p e = if p then Just e else Nothing+        g r l = catMaybes [f r Annotation.Tie_Right,f l Annotation.Tie_Left]+        h = rq_to_duration_err (show ("rqt_to_duration_a",z,x)) 2 . rqt_rq+    in zip (map h x) (zipWith g rt lt)++-- | 'Rq_Tied' variant of 'rq_can_notate'.+rqt_can_notate :: Dots -> [Rq_Tied] -> Bool+rqt_can_notate k = rq_can_notate k  . map rqt_rq++-- | 'Rq_Tied' variant of 'rq_to_cmn'.+--+-- > rqt_to_cmn (5,T) == Just ((4,T),(1,T))+-- > rqt_to_cmn (5/4,T) == Just ((1,T),(1/4,T))+-- > rqt_to_cmn (5/7,F) == Just ((4/7,T),(1/7,F))+rqt_to_cmn :: Rq_Tied -> Maybe (Rq_Tied,Rq_Tied)+rqt_to_cmn (k,t) =+    let f (i,j) = ((i,True),(j,t))+    in fmap f (rq_to_cmn k)++-- | List variant of 'rqt_to_cmn'.+--+-- > rqt_to_cmn_l (5,T) == [(4,T),(1,T)]+rqt_to_cmn_l :: Rq_Tied -> [Rq_Tied]+rqt_to_cmn_l x = maybe [x] (\(i,j) -> [i,j]) (rqt_to_cmn x)++-- | 'concatMap' 'rqt_to_cmn_l'.+--+-- > rqt_set_to_cmn [(1,T),(5/4,F)] == [(1,T),(1,T),(1/4,F)]+-- > rqt_set_to_cmn [(1/5,True),(1/20,False),(1/2,False),(1/4,True)]+rqt_set_to_cmn :: [Rq_Tied] -> [Rq_Tied]+rqt_set_to_cmn = concatMap rqt_to_cmn_l
Music/Theory/Duration/Sequence/Notate.hs view
@@ -1,7 +1,7 @@--- | Notation of a sequence of 'RQ' values as annotated 'Duration' values.+-- | Notation of a sequence of 'Rq' values as annotated 'Duration' values. -- -- 1. Separate input sequence into measures, adding tie annotations as--- required (see 'to_measures_ts').  Ensure all 'RQ_T' values can be+-- required (see 'to_measures_ts').  Ensure all 'Rq_Tied' values can be -- notated as /common music notation/ durations. -- -- 2. Separate each measure into pulses (see 'm_divisions_ts').@@ -17,53 +17,31 @@ -- 5. Ascribe values to notated durations, see 'ascribe'. module Music.Theory.Duration.Sequence.Notate where -import Control.Monad {- base -} import Data.List {- base -} import Data.List.Split {- split -} import Data.Maybe {- base -} import Data.Ratio {- base -} +import Music.Theory.Either {- hmt-base -}+import Music.Theory.Function {- hmt-base -}+import Music.Theory.List {- hmt-base -}+ import Music.Theory.Duration {- hmt -} import Music.Theory.Duration.Annotation {- hmt -}-import Music.Theory.Function {- hmt -}-import Music.Theory.Duration.RQ {- hmt -}-import Music.Theory.Duration.RQ.Tied {- hmt -}-import Music.Theory.List {- hmt -}+import Music.Theory.Duration.Rq {- hmt -}+import Music.Theory.Duration.Rq.Tied {- hmt -} import Music.Theory.Time_Signature {- hmt -}  -- * Lists --- | Variant of 'catMaybes'.  If all elements of the list are @Just--- a@, then gives @Just [a]@ else gives 'Nothing'.------ > all_just (map Just [1..3]) == Just [1..3]--- > all_just [Just 1,Nothing,Just 3] == Nothing-all_just :: [Maybe a] -> Maybe [a]-all_just x =-    case x of-      [] -> Just []-      Just i:x' -> fmap (i :) (all_just x')-      Nothing:_ -> Nothing+{- | Applies a /join/ function to the first two elements of the list.+     If the /join/ function succeeds the joined element is considered for further coalescing. --- | Variant of 'Data.Either.rights' that preserves first 'Left'.------ > all_right (map Right [1..3]) == Right [1..3]--- > all_right [Right 1,Left 'a',Left 'b'] == Left 'a'-all_right :: [Either a b] -> Either a [b]-all_right x =-    case x of-      [] -> Right []-      Right i:x' -> fmap (i :) (all_right x')-      Left i:_ -> Left i+> coalesce (\p q -> Just (p + q)) [1..5] == [15] --- | Applies a /join/ function to the first two elements of the list.--- If the /join/ function succeeds the joined element is considered--- for further coalescing.------ > coalesce (\p q -> Just (p + q)) [1..5] == [15]------ > let jn p q = if even p then Just (p + q) else Nothing--- > in coalesce jn [1..5] == map sum [[1],[2,3],[4,5]]+> let jn p q = if even p then Just (p + q) else Nothing+> coalesce jn [1..5] == map sum [[1],[2,3],[4,5]]+-} coalesce :: (a -> a -> Maybe a) -> [a] -> [a] coalesce f x =     case x of@@ -75,13 +53,13 @@  -- | Variant of 'coalesce' with accumulation parameter. ----- > coalesce_accum (\i p q -> Left (p + q)) 0 [1..5] == [(0,15)]+-- > coalesce_accum (\_ p q -> Left (p + q)) 0 [1..5] == [(0,15)] -- -- > let jn i p q = if even p then Left (p + q) else Right (p + i)--- > in coalesce_accum jn 0 [1..7] == [(0,1),(1,5),(6,9),(15,13)]+-- > coalesce_accum jn 0 [1..7] == [(0,1),(1,5),(6,9),(15,13)] -- -- > let jn i p q = if even p then Left (p + q) else Right [p,q]--- > in coalesce_accum jn [] [1..5] == [([],1),([1,2],5),([5,4],9)]+-- > coalesce_accum jn [] [1..5] == [([],1),([1,2],5),([5,4],9)] coalesce_accum :: (b -> a -> a -> Either a b) -> b -> [a] -> [(b,a)] coalesce_accum f i x =     case x of@@ -95,7 +73,7 @@ -- | Variant of 'coalesce_accum' that accumulates running sum. -- -- > let f i p q = if i == 1 then Just (p + q) else Nothing--- > in coalesce_sum (+) 0 f [1,1/2,1/4,1/4] == [1,1]+-- > coalesce_sum (+) 0 f [1,1/2,1/4,1/4] == [1,1] coalesce_sum :: (b -> a -> b) -> b -> (b -> a -> a -> Maybe a) -> [a] -> [a] coalesce_sum add zero f =     let g i p q = case f i p q of@@ -103,12 +81,6 @@                     Nothing -> Right (i `add` p)     in map snd . coalesce_accum g zero --- * Either---- | Lower 'Either' to 'Maybe' by discarding 'Left'.-either_to_maybe :: Either a b -> Maybe b-either_to_maybe = either (const Nothing) Just- -- * Separate  -- | Take elements while the sum of the prefix is less than or equal@@ -160,21 +132,21 @@                      Nothing -> Nothing       _ -> Nothing --- | Split sequence such that the prefix sums to precisely /m/.  The--- third element of the result indicates if it was required to divide--- an element.  Note that zero elements are kept left.  If the required--- sum is non positive, or the input list does not sum to at least the--- required sum, gives nothing.------ > split_sum 5 [2,3,1] == Just ([2,3],[1],Nothing)--- > split_sum 5 [2,1,3] == Just ([2,1,2],[1],Just (2,1))--- > split_sum 2 [3/2,3/2,3/2] == Just ([3/2,1/2],[1,3/2],Just (1/2,1))--- > split_sum 6 [1..10] == Just ([1..3],[4..10],Nothing)--- > fmap (\(a,_,c)->(a,c)) (split_sum 5 [1..]) == Just ([1,2,2],Just (2,1))--- > split_sum 0 [1..] == Nothing--- > split_sum 3 [1,1] == Nothing--- > split_sum 3 [2,1,0] == Just ([2,1,0],[],Nothing)--- > split_sum 3 [2,1,0,1] == Just ([2,1,0],[1],Nothing)+{- | Split sequence /l/ such that the prefix sums to precisely /m/.+     The third element of the result indicates if it was required to divide an element.+     Note that zero elements are kept left.+     If the required sum is non positive, or the input list does not sum to at least the required sum, gives nothing.++> split_sum 5 [2,3,1] == Just ([2,3],[1],Nothing)+> split_sum 5 [2,1,3] == Just ([2,1,2],[1],Just (2,1))+> split_sum 2 [3/2,3/2,3/2] == Just ([3/2,1/2],[1,3/2],Just (1/2,1))+> split_sum 6 [1..10] == Just ([1..3],[4..10],Nothing)+> fmap (\(a,_,c)->(a,c)) (split_sum 5 [1..]) == Just ([1,2,2],Just (2,1))+> split_sum 0 [1..] == Nothing+> split_sum 3 [1,1] == Nothing+> split_sum 3 [2,1,0] == Just ([2,1,0],[],Nothing)+> split_sum 3 [2,1,0,1] == Just ([2,1,0],[1],Nothing)+-} split_sum :: (Ord a, Num a) => a -> [a] -> Maybe ([a],[a],Maybe (a,a)) split_sum m l =     let (p,n,q) = take_sum m l@@ -186,24 +158,20 @@               [] -> Nothing               z:q' -> Just (p++[n],z-n:q',Just (n,z-n)) --- | Alias for 'True', used locally for documentation.-_t :: Bool-_t = True+{- | Variant of 'split_sum' that operates at 'Rq_Tied' sequences. --- | Alias for 'False', used locally for documentation.-_f :: Bool-_f = False+> t = True+> f = False --- | Variant of 'split_sum' that operates at 'RQ_T' sequences.------ > let r = Just ([(3,_f),(2,_t)],[(1,_f)])--- > in rqt_split_sum 5 [(3,_f),(2,_t),(1,_f)] == r------ > let r = Just ([(3,_f),(1,_t)],[(1,_t),(1,_f)])--- > in rqt_split_sum 4 [(3,_f),(2,_t),(1,_f)] == r------ > rqt_split_sum 4 [(5/2,False)] == Nothing-rqt_split_sum :: RQ -> [RQ_T] -> Maybe ([RQ_T],[RQ_T])+> r = Just ([(3,f),(2,t)],[(1,f)])+> rqt_split_sum 5 [(3,f),(2,t),(1,f)] == r++> r = Just ([(3,f),(1,t)],[(1,t),(1,f)])+> rqt_split_sum 4 [(3,f),(2,t),(1,f)] == r++> rqt_split_sum 4 [(5/2,False)] == Nothing+-}+rqt_split_sum :: Rq -> [Rq_Tied] -> Maybe ([Rq_Tied],[Rq_Tied]) rqt_split_sum d x =     case split_sum d (map rqt_rq x) of       Just (i,_,k) ->@@ -214,57 +182,61 @@                                   ,(q,z) : t)       Nothing -> Nothing --- | Separate 'RQ_T' values in sequences summing to 'RQ' values.  This--- is a recursive variant of 'rqt_split_sum'.  Note that is does not--- ensure /cmn/ notation of values.------ > let d = [(2,_f),(2,_f),(2,_f)]--- > in rqt_separate [3,3] d == Right [[(2,_f),(1,_t)]--- >                                  ,[(1,_f),(2,_f)]]------ > let d = [(5/8,_f),(1,_f),(3/8,_f)]--- > in rqt_separate [1,1] d == Right [[(5/8,_f),(3/8,_t)]--- >                                  ,[(5/8,_f),(3/8,_f)]]------ > let d = [(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)]--- > in rqt_separate [1,1,1] d == Right [[(4/7,_t),(1/7,_f),(2/7,_t)]--- >                                    ,[(5/7,_f),(2/7,_t)]--- >                                    ,[(4/7,_f),(3/7,_f)]]-rqt_separate :: [RQ] -> [RQ_T] -> Either String [[RQ_T]]+{- | Separate 'Rq_Tied' values in sequences summing to 'Rq' values.+    This is a recursive variant of 'rqt_split_sum'.+    Note that is does not ensure /cmn/ notation of values.++> t = True+> f = False++> d = [(2,f),(2,f),(2,f)]+> r = [[(2,f),(1,t)],[(1,f),(2,f)]]+> rqt_separate [3,3] d == Right r++> d = [(5/8,f),(1,f),(3/8,f)]+> r = [[(5/8,f),(3/8,t)],[(5/8,f),(3/8,f)]]+> rqt_separate [1,1] d == Right r++> d = [(4/7,t),(1/7,f),(1,f),(6/7,f),(3/7,f)]+> r = [[(4/7,t),(1/7,f),(2/7,t)],[(5/7,f),(2/7,t)],[(4/7,f),(3/7,f)]]+> rqt_separate [1,1,1] d == Right r+-}+rqt_separate :: [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]] rqt_separate m x =     case (m,x) of       ([],[]) -> Right []-      ([],_) -> Left (show ("rqt_separate",x))+      ([],_) -> Left (show ("rqt_separate: lhs empty, rhs non-empty",x))       (i:m',_) ->           case rqt_split_sum i x of             Just (r,x') -> fmap (r :) (rqt_separate m' x')-            Nothing -> Left (show ("rqt_separate",i,m',x))+            Nothing -> Left (show ("rqt_separate: rqt_split_sum failed",(i,x),m')) -rqt_separate_m :: [RQ] -> [RQ_T] -> Maybe [[RQ_T]]+-- | Maybe form ot 'rqt_separate'+rqt_separate_m :: [Rq] -> [Rq_Tied] -> Maybe [[Rq_Tied]] rqt_separate_m m = either_to_maybe . rqt_separate m --- | If the input 'RQ_T' sequence cannot be notated (see+-- | If the input 'Rq_Tied' sequence cannot be notated (see -- 'rqt_can_notate') separate into equal parts, so long as each part -- is not less than /i/. ----- > rqt_separate_tuplet undefined [(1/3,_f),(1/6,_f)]--- > rqt_separate_tuplet undefined [(4/7,_t),(1/7,_f),(2/7,_f)]+-- > rqt_separate_tuplet undefined [(1/3,f),(1/6,f)]+-- > rqt_separate_tuplet undefined [(4/7,t),(1/7,f),(2/7,f)] -- -- > let d = map rq_rqt [1/3,1/6,2/5,1/10]--- > in rqt_separate_tuplet (1/8) d == Right [[(1/3,_f),(1/6,_f)]--- >                                         ,[(2/5,_f),(1/10,_f)]]+-- > in rqt_separate_tuplet (1/8) d == Right [[(1/3,f),(1/6,f)]+-- >                                         ,[(2/5,f),(1/10,f)]] -- -- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)] -- > in rqt_separate_tuplet (1/16) d ----- > let d = [(2/5,_f),(1/5,_f),(1/5,_f),(1/5,_t),(1/2,_f),(1/2,_f)]+-- > let d = [(2/5,f),(1/5,f),(1/5,f),(1/5,t),(1/2,f),(1/2,f)] -- > in rqt_separate_tuplet (1/2) d -- -- > let d = [(4/10,True),(1/10,False),(1/2,True)] -- > in rqt_separate_tuplet (1/2) d-rqt_separate_tuplet :: RQ -> [RQ_T] -> Either String [[RQ_T]]+rqt_separate_tuplet :: Rq -> [Rq_Tied] -> Either String [[Rq_Tied]] rqt_separate_tuplet i x =-    if rqt_can_notate x+    if rqt_can_notate 2 x     then Left (show ("rqt_separate_tuplet: separation not required",x))     else let j = sum (map rqt_rq x) / 2          in if j < i@@ -274,10 +246,10 @@ -- | Recursive variant of 'rqt_separate_tuplet'. -- -- > let d = map rq_rqt [1,1/3,1/6,2/5,1/10]--- > in rqt_tuplet_subdivide (1/8) d == [[(1/1,_f)]--- >                                    ,[(1/3,_f),(1/6,_f)]--- >                                    ,[(2/5,_f),(1/10,_f)]]-rqt_tuplet_subdivide :: RQ -> [RQ_T] -> [[RQ_T]]+-- > in rqt_tuplet_subdivide (1/8) d == [[(1/1,f)]+-- >                                    ,[(1/3,f),(1/6,f)]+-- >                                    ,[(2/5,f),(1/10,f)]]+rqt_tuplet_subdivide :: Rq -> [Rq_Tied] -> [[Rq_Tied]] rqt_tuplet_subdivide i x =     case rqt_separate_tuplet i x of       Left _ -> [x]@@ -287,13 +259,13 @@ -- -- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)] -- > in rqt_tuplet_subdivide_seq (1/2) [d]-rqt_tuplet_subdivide_seq :: RQ -> [[RQ_T]] -> [[RQ_T]]+rqt_tuplet_subdivide_seq :: Rq -> [[Rq_Tied]] -> [[Rq_Tied]] rqt_tuplet_subdivide_seq i = concatMap (rqt_tuplet_subdivide i)  -- | If a tuplet is all tied, it ought to be a plain value?! ----- > rqt_tuplet_sanity_ [(4/10,_t),(1/10,_f)] == [(1/2,_f)]-rqt_tuplet_sanity_ :: [RQ_T] -> [RQ_T]+-- > rqt_tuplet_sanity_ [(4/10,t),(1/10,f)] == [(1/2,f)]+rqt_tuplet_sanity_ :: [Rq_Tied] -> [Rq_Tied] rqt_tuplet_sanity_ t =     let last_tied = rqt_tied (last t)         all_tied = all rqt_tied (dropRight 1 t)@@ -301,82 +273,86 @@        then [(sum (map rqt_rq t),last_tied)]        else t -rqt_tuplet_subdivide_seq_sanity_ :: RQ -> [[RQ_T]] -> [[RQ_T]]+rqt_tuplet_subdivide_seq_sanity_ :: Rq -> [[Rq_Tied]] -> [[Rq_Tied]] rqt_tuplet_subdivide_seq_sanity_ i =     map rqt_tuplet_sanity_ .     rqt_tuplet_subdivide_seq i  -- * Divisions --- | Separate 'RQ' sequence into measures given by 'RQ' length.+-- | Separate 'Rq' sequence into measures given by 'Rq' length. ----- > to_measures_rq [3,3] [2,2,2] == Right [[(2,_f),(1,_t)],[(1,_f),(2,_f)]]--- > to_measures_rq [3,3] [6] == Right [[(3,_t)],[(3,_f)]]--- > to_measures_rq [1,1,1] [3] == Right [[(1,_t)],[(1,_t)],[(1,_f)]]+-- > to_measures_rq [3,3] [2,2,2] == Right [[(2,f),(1,t)],[(1,f),(2,f)]]+-- > to_measures_rq [3,3] [6] == Right [[(3,t)],[(3,f)]]+-- > to_measures_rq [1,1,1] [3] == Right [[(1,t)],[(1,t)],[(1,f)]] -- > to_measures_rq [3,3] [2,2,1] -- > to_measures_rq [3,2] [2,2,2] -- -- > let d = [4/7,33/28,9/20,4/5]--- > in to_measures_rq [3] d == Right [[(4/7,_f),(33/28,_f),(9/20,_f),(4/5,_f)]]-to_measures_rq :: [RQ] -> [RQ] -> Either String [[RQ_T]]+-- > in to_measures_rq [3] d == Right [[(4/7,f),(33/28,f),(9/20,f),(4/5,f)]]+to_measures_rq :: [Rq] -> [Rq] -> Either String [[Rq_Tied]] to_measures_rq m = rqt_separate m . map rq_rqt --- | Variant of 'to_measures_rq' that ensures 'RQ_T' are /cmn/+-- | Variant that is applicable only at sequence that do not require splitting and ties, else error.+to_measures_rq_untied_err :: [Rq] -> [Rq] -> [[Rq]]+to_measures_rq_untied_err m = either (error "to_measures_rq_untied") (map (map rqt_to_rq_err)) . to_measures_rq m++-- | Variant of 'to_measures_rq' that ensures 'Rq_Tied' are /cmn/ -- durations.  This is not a good composition. ----- > to_measures_rq_cmn [6,6] [5,5,2] == Right [[(4,_t),(1,_f),(1,_t)]--- >                                           ,[(4,_f),(2,_f)]]+-- > to_measures_rq_cmn [6,6] [5,5,2] == Right [[(4,t),(1,f),(1,t)]+-- >                                           ,[(4,f),(2,f)]] ----- > let r = [[(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)]]+-- > let r = [[(4/7,t),(1/7,f),(1,f),(6/7,f),(3/7,f)]] -- > in to_measures_rq_cmn [3] [5/7,1,6/7,3/7] == Right r ----- > to_measures_rq_cmn [1,1,1] [5/7,1,6/7,3/7] == Right [[(4/7,_t),(1/7,_f),(2/7,_t)]--- >                                                     ,[(4/7,_t),(1/7,_f),(2/7,_t)]--- >                                                     ,[(4/7,_f),(3/7,_f)]]-to_measures_rq_cmn :: [RQ] -> [RQ] -> Either String [[RQ_T]]+-- > to_measures_rq_cmn [1,1,1] [5/7,1,6/7,3/7] == Right [[(4/7,t),(1/7,f),(2/7,t)]+-- >                                                     ,[(4/7,t),(1/7,f),(2/7,t)]+-- >                                                     ,[(4/7,f),(3/7,f)]]+to_measures_rq_cmn :: [Rq] -> [Rq] -> Either String [[Rq_Tied]] to_measures_rq_cmn m = fmap (map rqt_set_to_cmn) . to_measures_rq m  -- | Variant of 'to_measures_rq' with measures given by--- 'Time_Signature' values.  Does not ensure 'RQ_T' are /cmn/+-- 'Time_Signature' values.  Does not ensure 'Rq_Tied' are /cmn/ -- durations. ----- > to_measures_ts [(1,4)] [5/8,3/8] /= Right [[(1/2,_t),(1/8,_f),(3/8,_f)]]--- > to_measures_ts [(1,4)] [5/7,2/7] /= Right [[(4/7,_t),(1/7,_f),(2/7,_f)]]+-- > to_measures_ts [(1,4)] [5/8,3/8] /= Right [[(1/2,t),(1/8,f),(3/8,f)]]+-- > to_measures_ts [(1,4)] [5/7,2/7] /= Right [[(4/7,t),(1/7,f),(2/7,f)]] -- -- > let {m = replicate 18 (1,4) -- >     ;x = [3/4,2,5/4,9/4,1/4,3/2,1/2,7/4,1,5/2,11/4,3/2]}--- > in to_measures_ts m x == Right [[(3/4,_f),(1/4,_t)],[(1/1,_t)]--- >                                ,[(3/4,_f),(1/4,_t)],[(1/1,_f)]--- >                                ,[(1/1,_t)],[(1/1,_t)]--- >                                ,[(1/4,_f),(1/4,_f),(1/2,_t)],[(1/1,_f)]--- >                                ,[(1/2,_f),(1/2,_t)],[(1/1,_t)]--- >                                ,[(1/4,_f),(3/4,_t)],[(1/4,_f),(3/4,_t)]--- >                                ,[(1/1,_t)],[(3/4,_f),(1/4,_t)]--- >                                ,[(1/1,_t)],[(1/1,_t)]--- >                                ,[(1/2,_f),(1/2,_t)],[(1/1,_f)]]+-- > in to_measures_ts m x == Right [[(3/4,f),(1/4,t)],[(1/1,t)]+-- >                                ,[(3/4,f),(1/4,t)],[(1/1,f)]+-- >                                ,[(1/1,t)],[(1/1,t)]+-- >                                ,[(1/4,f),(1/4,f),(1/2,t)],[(1/1,f)]+-- >                                ,[(1/2,f),(1/2,t)],[(1/1,t)]+-- >                                ,[(1/4,f),(3/4,t)],[(1/4,f),(3/4,t)]+-- >                                ,[(1/1,t)],[(3/4,f),(1/4,t)]+-- >                                ,[(1/1,t)],[(1/1,t)]+-- >                                ,[(1/2,f),(1/2,t)],[(1/1,f)]] -- -- > to_measures_ts [(3,4)] [4/7,33/28,9/20,4/5] -- > to_measures_ts (replicate 3 (1,4)) [4/7,33/28,9/20,4/5]-to_measures_ts :: [Time_Signature] -> [RQ] -> Either String [[RQ_T]]+to_measures_ts :: [Time_Signature] -> [Rq] -> Either String [[Rq_Tied]] to_measures_ts m = to_measures_rq (map ts_rq m)  -- | Variant of 'to_measures_ts' that allows for duration field -- operation but requires that measures be well formed.  This is -- useful for re-grouping measures after notation and ascription.-to_measures_ts_by_eq :: (a -> RQ) -> [Time_Signature] -> [a] -> Maybe [[a]]+to_measures_ts_by_eq :: (a -> Rq) -> [Time_Signature] -> [a] -> Maybe [[a]] to_measures_ts_by_eq f m = split_sum_by_eq f (map ts_rq m) --- | Divide measure into pulses of indicated 'RQ' durations.  Measure+-- | Divide measure into pulses of indicated 'Rq' durations.  Measure -- must be of correct length but need not contain only /cmn/ -- durations.  Pulses are further subdivided if required to notate -- tuplets correctly, see 'rqt_tuplet_subdivide_seq'. ----- > let d = [(1/4,_f),(1/4,_f),(2/3,_t),(1/6,_f),(16/15,_f),(1/5,_f)--- >         ,(1/5,_f),(2/5,_t),(1/20,_f),(1/2,_f),(1/4,_t)]+-- > let d = [(1/4,f),(1/4,f),(2/3,t),(1/6,f),(16/15,f),(1/5,f)+-- >         ,(1/5,f),(2/5,t),(1/20,f),(1/2,f),(1/4,t)] -- > in m_divisions_rq [1,1,1,1] d ----- > m_divisions_rq [1,1,1] [(4/7,_f),(33/28,_f),(9/20,_f),(4/5,_f)]-m_divisions_rq :: [RQ] -> [RQ_T] -> Either String [[RQ_T]]+-- > m_divisions_rq [1,1,1] [(4/7,f),(33/28,f),(9/20,f),(4/5,f)]+m_divisions_rq :: [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]] m_divisions_rq z =     fmap (rqt_tuplet_subdivide_seq_sanity_ (1/16) .           map rqt_set_to_cmn) .@@ -385,59 +361,59 @@ -- | Variant of 'm_divisions_rq' that determines pulse divisions from -- 'Time_Signature'. ----- > let d = [(4/7,_t),(1/7,_f),(2/7,_f)]+-- > let d = [(4/7,t),(1/7,f),(2/7,f)] -- > in m_divisions_ts (1,4) d == Just [d] -- -- > let d = map rq_rqt [1/3,1/6,2/5,1/10]--- > in m_divisions_ts (1,4) d == Just [[(1/3,_f),(1/6,_f)]--- >                                   ,[(2/5,_f),(1/10,_f)]]+-- > in m_divisions_ts (1,4) d == Just [[(1/3,f),(1/6,f)]+-- >                                   ,[(2/5,f),(1/10,f)]] -- -- > let d = map rq_rqt [4/7,33/28,9/20,4/5]--- > in m_divisions_ts (3,4) d == Just [[(4/7,_f),(3/7,_t)]--- >                                   ,[(3/4,_f),(1/4,_t)]--- >                                   ,[(1/5,_f),(4/5,_f)]]-m_divisions_ts :: Time_Signature -> [RQ_T] -> Either String [[RQ_T]]+-- > in m_divisions_ts (3,4) d == Just [[(4/7,f),(3/7,t)]+-- >                                   ,[(3/4,f),(1/4,t)]+-- >                                   ,[(1/5,f),(4/5,f)]]+m_divisions_ts :: Time_Signature -> [Rq_Tied] -> Either String [[Rq_Tied]] m_divisions_ts ts = m_divisions_rq (ts_divisions ts)  {-| Composition of 'to_measures_rq' and 'm_divisions_rq', where measures are initially given as sets of divisions.  > let m = [[1,1,1],[1,1,1]]-> in to_divisions_rq m [2,2,2] == Right [[[(1,_t)],[(1,_f)],[(1,_t)]]->                                      ,[[(1,_f)],[(1,_t)],[(1,_f)]]]+> in to_divisions_rq m [2,2,2] == Right [[[(1,t)],[(1,f)],[(1,t)]]+>                                      ,[[(1,f)],[(1,t)],[(1,f)]]]  > let d = [2/7,1/7,4/7,5/7,8/7,1,1/7]-> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,_f),(1/7,_f),(4/7,_f)]->                                           ,[(4/7,_t),(1/7,_f),(2/7,_t)]->                                           ,[(6/7,_f),(1/7,_t)]->                                           ,[(6/7,_f),(1/7,_f)]]]+> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,f),(1/7,f),(4/7,f)]+>                                           ,[(4/7,t),(1/7,f),(2/7,t)]+>                                           ,[(6/7,f),(1/7,t)]+>                                           ,[(6/7,f),(1/7,f)]]]  > let d = [5/7,1,6/7,3/7]-> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,_t),(1/7,_f),(2/7,_t)]->                                         ,[(4/7,_t),(1/7,_f),(2/7,_t)]->                                         ,[(4/7,_f),(3/7,_f)]]]+> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,t),(1/7,f),(2/7,t)]+>                                         ,[(4/7,t),(1/7,f),(2/7,t)]+>                                         ,[(4/7,f),(3/7,f)]]]  > let d = [2/7,1/7,4/7,5/7,1,6/7,3/7]-> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,_f),(1/7,_f),(4/7,_f)]->                                           ,[(4/7,_t),(1/7,_f),(2/7,_t)]->                                           ,[(4/7,_t),(1/7,_f),(2/7,_t)]->                                           ,[(4/7,_f),(3/7,_f)]]]+> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,f),(1/7,f),(4/7,f)]+>                                           ,[(4/7,t),(1/7,f),(2/7,t)]+>                                           ,[(4/7,t),(1/7,f),(2/7,t)]+>                                           ,[(4/7,f),(3/7,f)]]]  > let d = [4/7,33/28,9/20,4/5]-> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,_f),(3/7,_t)]->                                          ,[(3/4,_f),(1/4,_t)]->                                          ,[(1/5,_f),(4/5,_f)]]]+> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,f),(3/7,t)]+>                                          ,[(3/4,f),(1/4,t)]+>                                          ,[(1/5,f),(4/5,f)]]]  > let {p = [[1/2,1,1/2],[1/2,1]] >     ;d = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]}-> in to_divisions_rq p d == Right [[[(1/6,_f),(1/6,_f),(1/6,_f)]->                                  ,[(1/6,_f),(1/6,_f),(1/6,_f),(1/2,True)]->                                  ,[(1/6,_f),(1/6,_f),(1/6,True)]]->                                 ,[[(1/6,_f),(1/6,_f),(1/6,_f)]->                                  ,[(1/3,_f),(1/6,_f),(1/2,_f)]]]+> in to_divisions_rq p d == Right [[[(1/6,f),(1/6,f),(1/6,f)]+>                                  ,[(1/6,f),(1/6,f),(1/6,f),(1/2,True)]+>                                  ,[(1/6,f),(1/6,f),(1/6,True)]]+>                                 ,[[(1/6,f),(1/6,f),(1/6,f)]+>                                  ,[(1/3,f),(1/6,f),(1/2,f)]]]  -}-to_divisions_rq :: [[RQ]] -> [RQ] -> Either String [[[RQ_T]]]+to_divisions_rq :: [[Rq]] -> [Rq] -> Either String [[[Rq_Tied]]] to_divisions_rq m x =     let m' = map sum m     in case to_measures_rq m' x of@@ -448,39 +424,39 @@ -- 'Time_Signature'. -- -- > let d = [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6]--- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)]--- >                                       ,[(1/3,_f),(1/6,_f),(1/2,_t)]--- >                                       ,[(1/5,_f),(4/5,_t)]--- >                                       ,[(1/3,_f),(1/2,_f),(1/6,_f)]]]+-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,f),(2/5,f)]+-- >                                       ,[(1/3,f),(1/6,f),(1/2,t)]+-- >                                       ,[(1/5,f),(4/5,t)]+-- >                                       ,[(1/3,f),(1/2,f),(1/6,f)]]] -- -- > let d = [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3]--- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)]--- >                                       ,[(1/3,_f),(1/6,_f),(1/2,_t)]--- >                                       ,[(1/5,_f),(4/5,_t)]--- >                                       ,[(1/6,_f),(1/2,_f),(1/3,_f)]]]+-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,f),(2/5,f)]+-- >                                       ,[(1/3,f),(1/6,f),(1/2,t)]+-- >                                       ,[(1/5,f),(4/5,t)]+-- >                                       ,[(1/6,f),(1/2,f),(1/3,f)]]] -- -- > let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2]--- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,_f),(2/5,_f)]--- >                                       ,[(1/3,_f),(1/6,_f),(1/2,_t)]--- >                                       ,[(1/5,_f),(4/5,_f)]--- >                                       ,[(1/2,_f),(1/2,_f)]]]+-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,f),(2/5,f)]+-- >                                       ,[(1/3,f),(1/6,f),(1/2,t)]+-- >                                       ,[(1/5,f),(4/5,f)]+-- >                                       ,[(1/2,f),(1/2,f)]]] -- -- > let d = [4/7,33/28,9/20,4/5]--- > in to_divisions_ts [(3,4)] d == Just [[[(4/7,_f),(3/7,_t)]--- >                                       ,[(3/4,_f),(1/4,_t)]--- >                                       ,[(1/5,_f),(4/5,_f)]]]-to_divisions_ts :: [Time_Signature] -> [RQ] -> Either String [[[RQ_T]]]+-- > in to_divisions_ts [(3,4)] d == Just [[[(4/7,f),(3/7,t)]+-- >                                       ,[(3/4,f),(1/4,t)]+-- >                                       ,[(1/5,f),(4/5,f)]]]+to_divisions_ts :: [Time_Signature] -> [Rq] -> Either String [[[Rq_Tied]]] to_divisions_ts ts = to_divisions_rq (map ts_divisions ts)  -- * Durations  -- | Pulse tuplet derivation. ----- > p_tuplet_rqt [(2/3,_f),(1/3,_t)] == Just ((3,2),[(1,_f),(1/2,_t)])--- > p_tuplet_rqt (map rq_rqt [1/3,1/6]) == Just ((3,2),[(1/2,_f),(1/4,_f)])--- > p_tuplet_rqt (map rq_rqt [2/5,1/10]) == Just ((5,4),[(1/2,_f),(1/8,_f)])+-- > p_tuplet_rqt [(2/3,f),(1/3,t)] == Just ((3,2),[(1,f),(1/2,t)])+-- > p_tuplet_rqt (map rq_rqt [1/3,1/6]) == Just ((3,2),[(1/2,f),(1/4,f)])+-- > p_tuplet_rqt (map rq_rqt [2/5,1/10]) == Just ((5,4),[(1/2,f),(1/8,f)]) -- > p_tuplet_rqt (map rq_rqt [1/3,1/6,2/5,1/10])-p_tuplet_rqt :: [RQ_T] -> Maybe ((Integer,Integer),[RQ_T])+p_tuplet_rqt :: [Rq_Tied] -> Maybe ((Integer,Integer),[Rq_Tied]) p_tuplet_rqt x =     let f t = (t,map (rqt_un_tuplet t) x)     in fmap f (rq_derive_tuplet (map rqt_rq x))@@ -488,31 +464,31 @@ -- | Notate pulse, ie. derive tuplet if neccesary. The flag indicates -- if the initial value is tied left. ----- > p_notate False [(2/3,_f),(1/3,_t)]--- > p_notate False [(2/5,_f),(1/10,_t)]--- > p_notate False [(1/4,_t),(1/8,_f),(1/8,_f)]+-- > p_notate False [(2/3,f),(1/3,t)]+-- > p_notate False [(2/5,f),(1/10,t)]+-- > p_notate False [(1/4,t),(1/8,f),(1/8,f)] -- > p_notate False (map rq_rqt [1/3,1/6]) -- > p_notate False (map rq_rqt [2/5,1/10]) -- > p_notate False (map rq_rqt [1/3,1/6,2/5,1/10]) == Nothing-p_notate :: Bool -> [RQ_T] -> Either String [Duration_A]+p_notate :: Bool -> [Rq_Tied] -> Either String [Duration_A] p_notate z x =     let f = p_simplify . rqt_to_duration_a z         d = case p_tuplet_rqt x of               Just (t,x') -> da_tuplet t (f x')               Nothing -> f x-    in if rq_can_notate (map rqt_rq x)+    in if rq_can_notate 2 (map rqt_rq x)        then Right d        else Left (show ("p_notate",z,x))  -- | Notate measure. ----- > m_notate True [[(2/3,_f),(1/3,_t)],[(1,_t)],[(1,_f)]]+-- > m_notate True [[(2/3,f),(1/3,t)],[(1,t)],[(1,f)]] -- -- > let f = m_notate False . concat -- -- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6]) -- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3])-m_notate :: Bool -> [[RQ_T]] -> Either String [Duration_A]+m_notate :: Bool -> [[Rq_Tied]] -> Either String [Duration_A] m_notate z m =     let z' = z : map (is_tied_right . last) m     in fmap concat (all_right (zipWith p_notate z' m))@@ -533,7 +509,7 @@ > in fmap mm_notate (to_divisions_rq p d)  -}-mm_notate :: [[[RQ_T]]] -> Either String [[Duration_A]]+mm_notate :: [[[Rq_Tied]]] -> Either String [[Duration_A]] mm_notate d =     let z = False : map (is_tied_right . last . last) d     in all_right (zipWith m_notate z d)@@ -542,13 +518,13 @@  -- | Structure given to 'Simplify_P' to decide simplification.  The -- structure is /(ts,start-rq,(left-rq,right-rq))/.-type Simplify_T = (Time_Signature,RQ,(RQ,RQ))+type Simplify_T = (Time_Signature,Rq,(Rq,Rq))  -- | Predicate function at 'Simplify_T'. type Simplify_P = Simplify_T -> Bool  -- | Variant of 'Simplify_T' allowing multiple rules.-type Simplify_M = ([Time_Signature],[RQ],[(RQ,RQ)])+type Simplify_M = ([Time_Signature],[Rq],[(Rq,Rq)])  -- | Transform 'Simplify_M' to 'Simplify_P'. meta_table_p :: Simplify_M -> Simplify_P@@ -641,7 +617,7 @@                 g i = if dots i <= n_dots && t && e && m && r                       then Just (i,a)                       else Nothing-            in join (fmap g d)+            in g =<< d         z i (j,_) = i + duration_to_rq j     in coalesce_sum z 0 f @@ -667,13 +643,13 @@ -- > p_simplify [(e,[Tie_Right]),(s,[Tie_Left]),(e',[])] == [(e',[]),(e',[])] -- -- > let f = rqt_to_duration_a False--- > in p_simplify (f [(1/8,_t),(1/4,_t),(1/8,_f)]) == f [(1/2,_f)]+-- > in p_simplify (f [(1/8,t),(1/4,t),(1/8,f)]) == f [(1/2,f)] p_simplify :: [Duration_A] -> [Duration_A] p_simplify = m_simplify p_simplify_rule undefined  -- * Notate -{-| Notate RQ duration sequence.  Derive pulse divisions from+{-| Notate Rq duration sequence.  Derive pulse divisions from 'Time_Signature' if not given directly.  Composition of 'to_divisions_ts', 'mm_notate' 'm_simplify'. @@ -684,7 +660,7 @@ >  in T.notate_rqp 4 sr ts (Just ts_p) rq  -}-notate_rqp :: Int -> Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] ->+notate_rqp :: Int -> Simplify_P -> [Time_Signature] -> Maybe [[Rq]] -> [Rq] ->               Either String [[Duration_A]] notate_rqp limit r ts ts_p x = do   let ts_p' = fromMaybe (map ts_divisions ts) ts_p@@ -695,9 +671,8 @@ -- | Variant of 'notate_rqp' without pulse divisions (derive). -- -- > notate 4 (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6]-notate :: Int -> Simplify_P -> [Time_Signature] -> [RQ] ->-          Either String [[Duration_A]]-notate limit r ts x = notate_rqp limit r ts Nothing x+notate :: Int -> Simplify_P -> [Time_Signature] -> [Rq] -> Either String [[Duration_A]]+notate limit r ts = notate_rqp limit r ts Nothing  -- * Ascribe @@ -779,15 +754,15 @@                in r : mm_ascribe mm' x'  -- | 'mm_ascribe of 'notate'.-notate_mm_ascribe :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] ->+notate_mm_ascribe :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[Rq]] -> [Rq] -> [a] ->                      Either String [[(Duration_A,a)]] notate_mm_ascribe limit r ts rqp d p =     let n = notate_rqp limit (default_rule r) ts rqp d         f = flip mm_ascribe p-        err str = show ("notate_ascribe",str,ts,d,p)+        err str = show ("notate_mm_ascribe",str,ts,d,p)     in either (Left . err) (Right . f) n -notate_mm_ascribe_err :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] ->+notate_mm_ascribe_err :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[Rq]] -> [Rq] -> [a] ->                          [[(Duration_A,a)]] notate_mm_ascribe_err = either error id .::::: notate_mm_ascribe
Music/Theory/Dynamic_Mark.hs view
@@ -9,62 +9,66 @@ 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+data Dynamic_Mark = 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,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+{- | Case insensitive reader for 'Dynamic_Mark'. --- | Lookup MIDI velocity for 'Dynamic_Mark_T'.  The range is linear--- in @0-127@.------ > let r = [0,6,17,28,39,50,61,72,83,94,105,116,127]--- > in mapMaybe dynamic_mark_midi [Niente .. FFFFF] == r------ > map dynamic_mark_midi [FP,SF,SFP,SFPP,SFZ,SFFZ] == replicate 6 Nothing-dynamic_mark_midi :: (Num n,Enum n) => Dynamic_Mark_T -> Maybe n+> map dynamic_mark_t_parse_ci (words "pP p Mp F")+-}+dynamic_mark_t_parse_ci :: String -> Maybe Dynamic_Mark+dynamic_mark_t_parse_ci =+  let capitalise x = toUpper (head x) : map toLower (tail x)+  in readMaybe . capitalise++{- | Lookup Midi velocity for 'Dynamic_Mark'.  The range is linear in @0-127@.++> let r = [0,6,17,28,39,50,61,72,83,94,105,116,127]+> mapMaybe dynamic_mark_midi [Niente .. Fffff] == r++> mapMaybe dynamic_mark_midi [Pp .. Ff] == [39,50,61,72,83,94]++> map dynamic_mark_midi [Fp,Sf,Sfp,Sfpp,Sfz,Sffz] == replicate 6 Nothing+-}+dynamic_mark_midi :: (Num n,Enum n) => Dynamic_Mark -> Maybe n dynamic_mark_midi m =     let r = zip [0..] (0 : reverse [127, 127-11 .. 0])     in lookup (fromEnum m) r  -- | Error variant.-dynamic_mark_midi_err :: Integral n => Dynamic_Mark_T -> n+dynamic_mark_midi_err :: Integral n => Dynamic_Mark -> n dynamic_mark_midi_err = fromMaybe (error "dynamic_mark_midi") . dynamic_mark_midi --- | Map midi velocity (0-127) to dynamic mark.------ > histogram (mapMaybe midi_dynamic_mark [0 .. 127])-midi_dynamic_mark :: (Ord n,Num n,Enum n) => n -> Maybe Dynamic_Mark_T+{- | Map midi velocity (0-127) to dynamic mark.++> histogram (mapMaybe midi_dynamic_mark [0 .. 127])+-}+midi_dynamic_mark :: (Ord n,Num n,Enum n) => n -> Maybe Dynamic_Mark midi_dynamic_mark m =     let r = zip (0 : [12,24 .. 132]) [0..]     in fmap (toEnum . snd) (find ((>= m) . fst) r) --- | Translate /fixed/ 'Dynamic_Mark_T's to /db/ amplitude over given--- /range/.------ > mapMaybe (dynamic_mark_db 120) [Niente,P,F,FFFFF] == [-120,-70,-40,0]--- > mapMaybe (dynamic_mark_db 60) [Niente,P,F,FFFFF] == [-60,-35,-20,0]-dynamic_mark_db :: Fractional n => n -> Dynamic_Mark_T -> Maybe n+{- | Translate /fixed/ 'Dynamic_Mark's to /db/ amplitude over given /range/.++> mapMaybe (dynamic_mark_db 120) [Niente,P,F,Fffff] == [-120,-70,-40,0]+> mapMaybe (dynamic_mark_db 60) [Niente,P,F,Fffff] == [-60,-35,-20,0]+-}+dynamic_mark_db :: Fractional n => n -> Dynamic_Mark -> Maybe n dynamic_mark_db r m =-    let u = [Niente .. FFFFF]+    let u = [Niente .. Fffff]         n = length u - 1         k = r / fromIntegral n         f i = negate r + (fromIntegral i * k)     in fmap f (elemIndex m u) --- | <http://www.csounds.com/manual/html/ampmidid.html>------ > import Sound.SC3.Plot--- > plotTable [map (ampmidid 20) [0 .. 127],map (ampmidid 60) [0 .. 127]]+{- | <http://www.csounds.com/manual/html/ampmidid.html>++> import Sound.Sc3.Plot {- hsc3-plot -}+> plot_p1_ln [map (ampmidid 20) [0 .. 127],map (ampmidid 60) [0 .. 127]]+-} ampmidid :: Floating a => a -> a -> a ampmidid db v =     let r = 10 ** (db / 20)@@ -72,26 +76,29 @@         m = (1 - b) / 127     in (m * v + b) ** 2 --- | JMcC (SC3) equation.------ > plotTable1 (map amp_db [0,0.005 .. 1])+{- | JMcC (Sc3) equation.++> plot_p1_ln [map amp_db [0,0.005 .. 1]]+-} amp_db :: Floating a => a -> a amp_db a = logBase 10 a * 20 --- | JMcC (SC3) equation.------ > plotTable1 (map db_amp [-60,-59 .. 0])+{- | JMcC (Sc3) equation.++> plot_p1_ln [map db_amp [-60,-59 .. 0]]+-} db_amp :: Floating a => a -> a db_amp a = 10 ** (a * 0.05)  -- | Enumeration of hairpin indicators.-data Hairpin_T = Crescendo | Diminuendo | End_Hairpin+data Hairpin = Crescendo | Diminuendo | End_Hairpin                  deriving (Eq,Ord,Enum,Bounded,Show) --- | The 'Hairpin_T' implied by a ordered pair of 'Dynamic_Mark_T's.------ > map (implied_hairpin MF) [MP,F] == [Just Diminuendo,Just Crescendo]-implied_hairpin :: Dynamic_Mark_T -> Dynamic_Mark_T -> Maybe Hairpin_T+{- | The 'Hairpin' implied by a ordered pair of 'Dynamic_Mark's.++> map (implied_hairpin Mf) [Mp,F] == [Just Diminuendo,Just Crescendo]+-}+implied_hairpin :: Dynamic_Mark -> Dynamic_Mark -> Maybe Hairpin implied_hairpin p q =     case compare p q of       LT -> Just Crescendo@@ -99,20 +106,18 @@       GT -> Just Diminuendo  -- | A node in a dynamic sequence.-type Dynamic_Node = (Maybe Dynamic_Mark_T,Maybe Hairpin_T)+type Dynamic_Node = (Maybe Dynamic_Mark,Maybe Hairpin)  -- | The empty 'Dynamic_Node'. empty_dynamic_node :: Dynamic_Node empty_dynamic_node = (Nothing,Nothing) --- | Calculate a 'Dynamic_Node' sequence from a sequence of--- 'Dynamic_Mark_T's.------ > dynamic_sequence [PP,MP,MP,PP] == [(Just PP,Just Crescendo)--- >                                   ,(Just MP,Just End_Hairpin)--- >                                   ,(Nothing,Just Diminuendo)--- >                                   ,(Just PP,Just End_Hairpin)]-dynamic_sequence :: [Dynamic_Mark_T] -> [Dynamic_Node]+{- | Calculate a 'Dynamic_Node' sequence from a sequence of 'Dynamic_Mark's.++> let r = [(Just Pp,Just Crescendo), (Just Mp,Just End_Hairpin) ,(Nothing,Just Diminuendo) ,(Just Pp,Just End_Hairpin)]+> dynamic_sequence [Pp,Mp,Mp,Pp] == r+-}+dynamic_sequence :: [Dynamic_Mark] -> [Dynamic_Node] dynamic_sequence d =     let h = zipWith implied_hairpin d (tail d) ++ [Nothing]         e = Just End_Hairpin@@ -127,11 +132,12 @@                             Just _ -> (j,k) : rec True p'     in rec False (zip (T.indicate_repetitions d) h) --- | Delete redundant (unaltered) dynamic marks.------ > let s = [Just P,Nothing,Just P,Just P,Just F]--- > in delete_redundant_marks s == [Just P,Nothing,Nothing,Nothing,Just F]-delete_redundant_marks :: [Maybe Dynamic_Mark_T] -> [Maybe Dynamic_Mark_T]+{- | Delete redundant (unaltered) dynamic marks.++> let r = [Just P,Nothing,Nothing,Nothing,Just F]+> delete_redundant_marks [Just P,Nothing,Just P,Just P,Just F] == r+-}+delete_redundant_marks :: [Maybe Dynamic_Mark] -> [Maybe Dynamic_Mark] delete_redundant_marks =     let f i j = case (i,j) of                   (Just a,Just b) -> if a == b then (j,Nothing) else (j,j)@@ -139,47 +145,46 @@                   (Nothing,_) -> (j,j)     in snd . mapAccumL f Nothing --- | Variant of 'dynamic_sequence' for sequences of 'Dynamic_Mark_T'--- with holes (ie. rests).  Runs 'delete_redundant_marks'.------ > let r = [Just (Just P,Just Crescendo),Just (Just F,Just End_Hairpin)--- >         ,Nothing,Just (Just P,Nothing)]--- > in dynamic_sequence_sets [Just P,Just F,Nothing,Just P] == r------ > let s = [Just P,Nothing,Just P]--- > in dynamic_sequence_sets s = [Just (Just P,Nothing),Nothing,Nothing]-dynamic_sequence_sets :: [Maybe Dynamic_Mark_T] -> [Maybe Dynamic_Node]+{- | Variant of 'dynamic_sequence' for sequences of 'Dynamic_Mark' with holes (ie. rests).+Runs 'delete_redundant_marks'.++> let r = [Just (Just P,Just Crescendo),Just (Just F,Just End_Hairpin),Nothing,Just (Just P,Nothing)]+> dynamic_sequence_sets [Just P,Just F,Nothing,Just P] == r++> dynamic_sequence_sets [Just P,Nothing,Just P] == [Just (Just P,Nothing),Nothing,Nothing]+-}+dynamic_sequence_sets :: [Maybe Dynamic_Mark] -> [Maybe Dynamic_Node] dynamic_sequence_sets =     let f l = case l of                 Nothing:_ -> map (const Nothing) l                 _ -> map Just (dynamic_sequence (catMaybes l))     in concatMap f . T.group_just . delete_redundant_marks --- | Apply 'Hairpin_T' and 'Dynamic_Mark_T' functions in that order as--- required by 'Dynamic_Node'.------ > 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 'Hairpin' and 'Dynamic_Mark' functions in that order as required by 'Dynamic_Node'.++> let f _ x = show x+> apply_dynamic_node f f (Nothing,Just Crescendo) undefined+-}+apply_dynamic_node :: (a -> Dynamic_Mark -> a) -> (a -> Hairpin -> 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 --- * ASCII+-- * Ascii --- | ASCII pretty printer for 'Dynamic_Mark_T'.-dynamic_mark_ascii :: Dynamic_Mark_T -> String+-- | Ascii pretty printer for 'Dynamic_Mark'.+dynamic_mark_ascii :: Dynamic_Mark -> String dynamic_mark_ascii = map toLower . show --- | ASCII pretty printer for 'Hairpin_T'.-hairpin_ascii :: Hairpin_T -> String+-- | Ascii pretty printer for 'Hairpin'.+hairpin_ascii :: Hairpin -> String hairpin_ascii hp =     case hp of       Crescendo -> "<"       Diminuendo -> ">"       End_Hairpin -> "" --- | ASCII pretty printer for 'Dynamic_Node'.+-- | Ascii pretty printer for 'Dynamic_Node'. dynamic_node_ascii :: Dynamic_Node -> String dynamic_node_ascii (mk,hp) =     let mk' = maybe "" dynamic_mark_ascii mk@@ -190,9 +195,9 @@          (_,[]) -> mk'          _ -> mk' ++ " " ++ hp' --- | ASCII pretty printer for 'Dynamic_Node' sequence.+-- | Ascii pretty printer for 'Dynamic_Node' sequence. dynamic_sequence_ascii :: [Dynamic_Node] -> String dynamic_sequence_ascii =-    intercalate " " .+    unwords .     filter (not . null) .     map dynamic_node_ascii
− Music/Theory/Either.hs 
@@ -1,28 +0,0 @@--- | Either-module Music.Theory.Either where--import Data.Maybe {- base -}---- | Maybe 'Left' of 'Either'.-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'.-from_right :: Either x t -> Maybe t-from_right e =-    case e of-      Left _ -> Nothing-      Right r -> Just r--from_right_err :: Either e t -> t-from_right_err = fromMaybe (error "from_right_err") . from_right---- | Flip from right to left, ie. 'either' 'Right' 'Left'-either_swap :: Either a b -> Either b a-either_swap = either Right Left
− Music/Theory/Enum.hs 
@@ -1,38 +0,0 @@--- | Enumeration functions.-module Music.Theory.Enum where---- | Generic variant of 'fromEnum' (p.263).-genericFromEnum :: (Integral i,Enum e) => e -> i-genericFromEnum = fromIntegral . fromEnum---- | Generic variant of 'toEnum' (p.263).-genericToEnum :: (Integral i,Enum e) => i -> e-genericToEnum = toEnum . fromIntegral---- | Variant of 'enumFromTo' that, if /p/ is after /q/, cycles from--- 'maxBound' to 'minBound'.------ > import Data.Word--- > enum_from_to_cyclic (254 :: Word8) 1 == [254,255,0,1]-enum_from_to_cyclic :: (Bounded a, Enum a) => a -> a -> [a]-enum_from_to_cyclic p q =-    if fromEnum p > fromEnum q-    then [p .. maxBound] ++ [minBound .. q]-    else [p .. q]---- | Variant of 'enumFromTo' that, if /p/ is after /q/, enumerates--- from /q/ to /p/.------ > enum_from_to_reverse 5 1 == [5,4,3,2,1]--- > enum_from_to_reverse 1 5 == enumFromTo 1 5-enum_from_to_reverse :: Enum a => a -> a -> [a]-enum_from_to_reverse p q =-    if fromEnum p > fromEnum q-    then reverse [q .. p]-    else [p .. q]---- | All elements in sequence.------ > (enum_univ :: [Data.Word.Word8]) == [0 .. 255]-enum_univ :: (Bounded t,Enum t) => [t]-enum_univ = [minBound .. maxBound]
− Music/Theory/Function.hs 
@@ -1,84 +0,0 @@--- | "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--- > const (const 5) undefined undefined == 5-const2 :: a -> b -> c -> a-const2 x _ _ = x---- * Predicate composition.---- | '&&' 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---- | List variant of 'predicate_and', ie. 'foldr1'------ > let r = [False,False,True,False,True,False]--- > map (predicate_all [(> 0),(< 5),even]) [0..5] == r-predicate_all :: [t -> Bool] -> t -> Bool-predicate_all = foldr1 predicate_and---predicate_all p x = all id (map ($ x) p)---- | '||' of predicates.-predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool-predicate_or f g x = f x || g x---- | 'any' of predicates, ie. logical /or/ of list of predicates.------ > let r = [True,False,True,False,True,True]--- > 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-infixr 8 .:, .::, .:::, .::::, .:::::---- | 'fmap' '.' 'fmap', ie. @(t -> c) -> (a -> b -> t) -> a -> b -> c@.-(.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)-(.:) = fmap . fmap---- | 'fmap' '.' '.:', ie. @(t -> d) -> (a -> b -> c -> t) -> a -> b -> c -> d@.-(.::) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))-(.::) = fmap . (.:)---- | 'fmap' '.' '.::'.-(.:::) :: (Functor f, Functor g, Functor h,Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b)))-(.:::) = fmap . (.::)---- | 'fmap' '.' '.:::'.-(.::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b))))-(.::::) = fmap . (.:::)---- | 'fmap' '.' '.::::'.-(.:::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j,Functor k) => (a -> b) -> f (g (h (i (j (k a))))) -> f (g (h (i (j (k b)))))-(.:::::) = fmap . (.::::)---- * Bimap---- | Apply /f/ to both elements of a two-tuple, ie. 'bimap' /f/ /f/.-bimap1 :: (t -> u) -> (t,t) -> (u,u)-bimap1 f (p,q) = (f p,f q)
Music/Theory/Gamelan.hs view
@@ -1,3 +1,4 @@+-- | Gamelan instruments and pitch structures. module Music.Theory.Gamelan where  import Data.Char {- base -}@@ -7,11 +8,12 @@ import Data.Ratio {- base -} import Text.Printf {- base -} +import qualified Music.Theory.Enum as T {- hmt-base -}+ import qualified Music.Theory.Clef as T {- hmt -}-import qualified Music.Theory.Enum as T {- hmt -} import qualified Music.Theory.Pitch as T {- hmt -} import qualified Music.Theory.Tuning as T {- hmt -}-import qualified Music.Theory.Tuning.ET as T {- hmt-diagrams -}+import qualified Music.Theory.Tuning.Et as T {- hmt-diagrams -}  -- | 'fromJust' with error message. fromJust_err :: String -> Maybe a -> a@@ -196,14 +198,14 @@  tone_24et_pitch :: Tone t -> Maybe T.Pitch tone_24et_pitch =-    let f i = let (_,pt,_,_,_) = T.nearest_24et_tone i in pt+    let f i = let (_,pt,_,_,_) = T.nearest_24et_tone_k0 (69,440) i in pt     in fmap f . tone_frequency  tone_24et_pitch' :: Tone t -> T.Pitch tone_24et_pitch' = fromJust_err "tone_24et_pitch" . tone_24et_pitch  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 = fmap (T.nearest_pitch_detune_24et_k0 (69,440)) . tone_frequency  tone_24et_pitch_detune' :: Tone t -> T.Pitch_Detune tone_24et_pitch_detune' = fromJust_err "tone_24et_pitch_detune" . tone_24et_pitch_detune@@ -217,14 +219,14 @@  tone_12et_pitch :: Tone t -> Maybe T.Pitch tone_12et_pitch =-    let f i = let (_,pt,_,_,_) = T.nearest_12et_tone i in pt+    let f i = let (_,pt,_,_,_) = T.nearest_12et_tone_k0 (69,440) i in pt     in fmap f . tone_frequency  tone_12et_pitch' :: Tone t -> T.Pitch tone_12et_pitch' = fromJust_err "tone_12et_pitch" . tone_12et_pitch  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 = fmap (T.nearest_pitch_detune_12et_k0 (69,440)) . tone_frequency  tone_12et_pitch_detune' :: Tone t -> T.Pitch_Detune tone_12et_pitch_detune' = fromJust_err "tone_12et_pitch_detune" . tone_12et_pitch_detune@@ -305,7 +307,7 @@ -- | Compare 'Tone's by frequency.  'Tone's without frequency compare -- as if at frequency @0@. tone_compare_frequency :: Tone t -> Tone t -> Ordering-tone_compare_frequency = compare `on` (maybe 0 id . tone_frequency)+tone_compare_frequency = compare `on` (fromMaybe 0 . tone_frequency)  -- | If all /f/ of /a/ are 'Just' /b/, then 'Just' /[b]/, else -- 'Nothing'.@@ -354,7 +356,7 @@ -- > degree_index Slendro 4 == Nothing -- > degree_index Pelog 4 == Just 3 degree_index :: Scale -> Degree -> Maybe Int-degree_index s d = findIndex (== d) (scale_degrees s)+degree_index s d = elemIndex d (scale_degrees s)  -- * Tone set
Music/Theory/Graph/Deacon_1934.hs view
@@ -6,25 +6,27 @@ -- Ireland, 64:129—175, 1934. module Music.Theory.Graph.Deacon_1934 where +import Data.Bifunctor {- base -} import Data.List {- base -} -import qualified Music.Theory.Array.Cell_Ref as T {- hmt -}+import qualified Music.Theory.Array.Cell_Ref as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Tuple as T {- hmt-base -}+ import qualified Music.Theory.Array.Direction as T {- hmt -} import qualified Music.Theory.Graph.Dot as T {- hmt -}-import qualified Music.Theory.Graph.FGL as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Tuple as T {- hmt -}+import qualified Music.Theory.Graph.Fgl as T {- hmt -} -gen_graph :: Ord v => [T.DOT_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]+gen_graph :: Ord v => [T.Dot_Attr] -> T.Graph_Pp v e -> [T.Edge_Lbl v e] -> [String] 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 :: Ord v => [T.Dot_Attr] -> (v -> String) -> [T.Edge v] -> [String] 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.fgl_to_dot T.G_DIGRAPH opt pp (T.g_from_edges_l es)+gen_digraph :: Ord v => [T.Dot_Attr] -> T.Graph_Pp v e -> [T.Edge_Lbl v e] -> [String]+gen_digraph opt pp es = T.fgl_to_dot T.Graph_Digraph opt pp (T.g_from_edges_l es) -type G = ([T.EDGE String],[T.DOT_ATTR],FilePath)+type G = ([T.Edge String],[T.Dot_Attr],FilePath)  -- * E g1 :: G@@ -66,7 +68,7 @@ g9 :: G g9 =     let d9' = ("E6",words "U R D LL (03/D6) U R R U L D D LL (11/C6) U R R U U R D L L D D LL (22/B6) U R R U U R R U L D D L L D D LL (38/A6) U R R U U R R U U R D L L D D L L D D LUU (56/A4) R R U U R R U L D D L L D D L UU (71/A3) R R U U R D L L D D L UU (83/A2) R R U L D D L UU (91/A1) R D L")-        d9 = (fst d9',filter T.is_direction (snd d9'))+        d9 = second (filter T.is_direction) d9'         c9 = T.dir_seq_to_cell_seq d9         o9 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]     in (T.adj2 1 c9,o9,"F")@@ -74,7 +76,7 @@ g10 :: G g10 =     let d10' = ("B7",words "U R LL (03/A6) R R U L D D LUU (10/A5) R R U L D D L UU (18/A4) R R U L D D L UU (26/A3) R R U L D D L UU (34/A2) R R U L D D L UU (41/A1) R D L")-        d10 = (fst d10',filter T.is_direction (snd d10'))+        d10 = second (filter T.is_direction) d10'         c10 = T.dir_seq_to_cell_seq d10         e10 = T.adj2 1 c10         o10 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]@@ -83,7 +85,7 @@ g11 :: G g11 =     let d11' = ("C3",words "DR DDL UUR U L (05/C3) DL DDR UUL U R (10/C3) D D U UL UUR DDL (16/B3) DL R U (18/B3) L DR R (21/C4) UR UUL DDR DR L (26/D4) U R DL L U (31/C3) U D (33/C3) R UUR DDDDD UUL L . (40/C4) L DDL UUUUU DDR R (44/C3)")-        d11 = (fst d11',filter T.is_direction (snd d11'))+        d11 = second (filter T.is_direction) d11'         c11 = T.dir_seq_to_cell_seq d11         e11 = T.adj2 1 c11         o11 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]@@ -92,7 +94,7 @@ g12 :: G g12 =     let d12' = ("C2",words "DR UR (02/E2) L DL UL L (06/A2) DR UR UR DR (10/E2) L UL DL L (14/A2) UR DR (16/C2)")-        d12 = (fst d12',filter T.is_direction (snd d12'))+        d12 = second (filter T.is_direction) d12'         c12 = T.dir_seq_to_cell_seq d12         e12 = T.adj2 1 c12         o12 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]@@ -101,7 +103,7 @@ g13 :: G g13 =     let d13' = ("B3",words "U D D U R DDL UUL R (07/C3) R UU DDL L UU DDR (11/C3)")-        d13 = (fst d13',filter T.is_direction (snd d13'))+        d13 = second (filter T.is_direction) d13'         c13 = T.dir_seq_to_cell_seq d13         e13 = T.adj2 1 c13         o13 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]
Music/Theory/Graph/Dot.hs view
@@ -9,13 +9,14 @@  import qualified Data.Graph.Inductive.Graph as G {- fgl -} -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 -}+import qualified Music.Theory.Graph.Type as T {- hmt-base -}+import qualified Music.Theory.List as List {- hmt-base -}+import qualified Music.Theory.Show as Show {- hmt-base -} --- * UTIL+import qualified Music.Theory.Graph.Fgl as T {- hmt -} +-- * Util+ -- | 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 =@@ -33,7 +34,7 @@ -- -- > 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 ((==) '.'))+is_number = s_classify isDigit (\c -> isDigit c || c == '.') ((< 2) . length . filter ('.' ==))  -- | Quote /s/ if 'is_symbol' or 'is_number'. --@@ -41,55 +42,55 @@ maybe_quote :: String -> String maybe_quote s = if is_symbol s || is_number s then s else concat ["\"",s,"\""] --- * ATTR/KEY+-- * Attr/Key -type DOT_KEY = String-type DOT_VALUE = String-type DOT_ATTR = (DOT_KEY,DOT_VALUE)+type Dot_Key = String+type Dot_Value = String+type Dot_Attr = (Dot_Key,Dot_Value) --- | Format 'DOT_ATTR'.-dot_attr_pp :: DOT_ATTR -> String+-- | Format 'Dot_Attr'.+dot_attr_pp :: Dot_Attr -> String dot_attr_pp (lhs,rhs) = concat [lhs,"=",maybe_quote rhs] --- | Format sequence of DOT_ATTR.+-- | 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 :: [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 :: [Dot_Attr] -> [Dot_Attr] -> [Dot_Attr] dot_attr_ext = List.assoc_merge  -- | graph|node|edge-type DOT_TYPE = String+type Dot_Type = String  -- | (type,[attr])-type DOT_ATTR_SET = (DOT_TYPE,[DOT_ATTR])+type Dot_Attr_Set = (Dot_Type,[Dot_Attr]) --- | Format DOT_ATTR_SET.+-- | 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 :: Dot_Attr_Set -> String dot_attr_set_pp (ty,opt) = concat [ty," ",dot_attr_seq_pp opt]  -- | type:attr (type = graph|node|edge)-type DOT_META_KEY = String+type Dot_Meta_Key = String -type DOT_META_ATTR = (DOT_META_KEY,DOT_VALUE)+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 :: 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]+-- | 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@@ -99,19 +100,20 @@ -- -- > 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 :: (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  -- | Graph pretty-printer, (v -> [attr],e -> [attr])-type GR_PP v e = ((Int,v) -> [DOT_ATTR],((Int,Int),e) -> [DOT_ATTR])+type Graph_Pp v e = ((Int,v) -> [Dot_Attr],((Int,Int),e) -> [Dot_Attr]) -gr_pp_label_m :: Maybe (v -> DOT_VALUE) -> Maybe (e -> DOT_VALUE) -> GR_PP v e+-- | Make Graph_Pp value given label functions for vertices and edges.+gr_pp_label_m :: Maybe (v -> Dot_Value) -> Maybe (e -> Dot_Value) -> Graph_Pp v e gr_pp_label_m f_v f_e =   let lift m (_,x) = case m of                        Nothing -> []@@ -119,11 +121,11 @@   in (lift f_v,lift f_e)  -- | Label V & E.-gr_pp_label :: (v -> DOT_VALUE) -> (e -> DOT_VALUE) -> GR_PP v e+gr_pp_label :: (v -> Dot_Value) -> (e -> Dot_Value) -> Graph_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 :: (v -> Dot_Value) -> Graph_Pp v e gr_pp_label_v f = gr_pp_label_m (Just f) Nothing  -- | br = brace, csl = comma separated list@@ -134,43 +136,44 @@       _ -> List.bracket ('{','}') (intercalate "," (map show l))  -- | Graph type, directed or un-directed.-data G_TYPE = G_DIGRAPH | G_UGRAPH+data Graph_Type = Graph_Digraph | Graph_Ugraph -g_type_to_string :: G_TYPE -> String+g_type_to_string :: Graph_Type -> String g_type_to_string ty =     case ty of-      G_DIGRAPH -> "digraph"-      G_UGRAPH -> "graph"+      Graph_Digraph -> "digraph"+      Graph_Ugraph -> "graph" -g_type_to_edge_symbol :: G_TYPE -> String+g_type_to_edge_symbol :: Graph_Type -> String g_type_to_edge_symbol ty =     case ty of-      G_DIGRAPH -> " -> "-      G_UGRAPH -> " -- "+      Graph_Digraph -> " -> "+      Graph_Ugraph -> " -- " -node_pos_attr :: (Show n, Real n) => (n,n) -> DOT_ATTR+-- | Generate node position attribute given (x,y) coordinate.+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 :: 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 :: 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_lift_pos_fn :: (v -> (Int,Int)) -> v -> [DOT_ATTR]+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 :: Graph_Type -> [Dot_Meta_Attr] -> Graph_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))),";"]@@ -182,28 +185,29 @@               ,map e_f e               ,["}"]] -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+lbl_to_udot :: [Dot_Meta_Attr] -> Graph_Pp v e -> T.Lbl v e -> [String]+lbl_to_udot = lbl_to_dot Graph_Ugraph -fgl_to_dot :: G.Graph gr => G_TYPE -> [DOT_META_ATTR] -> GR_PP v e -> gr v e -> [String]+-- | 'writeFile' of 'lbl_to_udot'+lbl_to_udot_wr :: FilePath -> [Dot_Meta_Attr] -> Graph_Pp v e -> T.Lbl v e -> IO ()+lbl_to_udot_wr fn o pp  = writeFile fn . unlines . lbl_to_udot o pp++fgl_to_dot :: G.Graph gr => Graph_Type -> [Dot_Meta_Attr] -> Graph_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 :: G.Graph gr => [Dot_Meta_Attr] -> Graph_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)+-- * Dot-Process -   /-n/ must be given to not run the layout algorithm and to use position data in the /dot/ file.+{- | 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-+-- | 'dot_to_ext' generating .svg filename by replacing .dot extension with .svg+dot_to_svg :: [String] -> FilePath -> IO ()+dot_to_svg opt dot_fn = dot_to_ext opt dot_fn (replaceExtension dot_fn "svg")
− Music/Theory/Graph/FGL.hs 
@@ -1,139 +0,0 @@--- | Graph (fgl) functions.-module Music.Theory.Graph.FGL where--import Data.List {- base -}-import Data.Maybe {- base -}--import qualified Data.Map as M {- containers -}--import qualified Data.Graph.Inductive.Graph as G {- fgl -}-import qualified Data.Graph.Inductive.Query as G {- fgl -}-import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -}--import qualified Control.Monad.Logic as L {- logict -}--import qualified Music.Theory.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---- | 'G.subgraph' of each of 'G.components'.-g_partition :: G.Gr v e -> [G.Gr v e]-g_partition gr = map (\n -> G.subgraph n gr) (G.components gr)---- | Find first 'G.Node' with given label.-g_node_lookup :: (Eq v,G.Graph gr) => gr v e -> v -> Maybe G.Node-g_node_lookup gr l = fmap fst (find ((== l) . snd) (G.labNodes gr))---- | Erroring variant.-g_node_lookup_err :: (Eq v,G.Graph gr) => gr v e -> v -> G.Node-g_node_lookup_err gr = fromMaybe (error "g_node_lookup") . g_node_lookup gr---- | Set of nodes with given labels, plus all neighbours of these nodes.--- (impl = implications)-ug_node_set_impl :: (Eq v,G.DynGraph gr) => gr v e -> [v] -> [G.Node]-ug_node_set_impl gr nl =-    let n = map (g_node_lookup_err gr) nl-    in nub (sort (n ++ concatMap (G.neighbors gr) n))---- * Hamiltonian--type G_NODE_SEL_F v e = G.Gr v e -> G.Node -> [G.Node]---- | 'L.msum' '.' 'map' 'return'.-ml_from_list :: L.MonadLogic m => [t] -> m t-ml_from_list = L.msum . map return---- | Use /sel_f/ of 'G.pre' for directed graphs and 'G.neighbors' for undirected.-g_hamiltonian_path_ml :: L.MonadLogic m => G_NODE_SEL_F v e -> G.Gr v e -> G.Node -> m [G.Node]-g_hamiltonian_path_ml sel_f gr =-    let n_deg = g_degree gr-        recur r c =-            if length r == n_deg - 1-            then return (c:r)-            else do i <- ml_from_list (sel_f gr c)-                    L.guard (i `notElem` r)-                    recur (c:r) i-    in recur []---- > map (L.observeAll . ug_hamiltonian_path_ml_0) (g_partition gr)-ug_hamiltonian_path_ml_0 :: L.MonadLogic m => G.Gr v e -> m [G.Node]-ug_hamiltonian_path_ml_0 gr = g_hamiltonian_path_ml G.neighbors gr (G.nodes gr !! 0)---- * G (from edges)---- | Edge, no label.-type EDGE v = (v,v)---- | Edge, with label.-type EDGE_L v l = (EDGE v,l)---- | Generate a graph given a set of labelled edges.-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-        n_id = [0 .. n_deg - 1]-        m = M.fromList (zip n n_id)-        m_get k = M.findWithDefault (error "g_from_edges: m_get") k m-        e' = map (\((lhs,rhs),label) -> (m_get lhs,m_get rhs,label)) e-    in G.mkGraph (zip n_id n) e'---- | Variant that supplies '()' as the (constant) edge label.------ > let g = G.mkGraph [(0,'a'),(1,'b'),(2,'c')] [(0,1,()),(1,2,())]--- > in g_from_edges_ul [('a','b'),('b','c')] == g-g_from_edges :: Ord v => [EDGE v] -> G.Gr v ()-g_from_edges = let f e = (e,()) in g_from_edges_l . map f---- * Edges---- | Label sequence of edges starting at one.-e_label_seq :: [EDGE v] -> [EDGE_L v Int]-e_label_seq = map (\(k,e) -> (e,k)) . zip [1..]---- | Normalised undirected labeled edge (ie. order nodes).-e_normalise_l :: Ord v => EDGE_L v l -> EDGE_L v l-e_normalise_l ((p,q),r) = ((min p q,max p q),r)---- | Collate labels for edges that are otherwise equal.-e_collate_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]]-e_collate_l = T.collate---- | 'e_collate_l' of 'e_normalise_l'.-e_collate_normalised_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]]-e_collate_normalised_l = e_collate_l . map e_normalise_l---- | Apply predicate to universe of possible edges.-e_univ_select_edges :: (t -> t -> Bool) -> [t] -> [EDGE t]-e_univ_select_edges f l = [(p,q) | p <- l, q <- l, f p q]---- | Consider only edges (p,q) where p < q.-e_univ_select_u_edges :: Ord t => (t -> t -> Bool) -> [t] -> [EDGE t]-e_univ_select_u_edges f = let g p q = p < q && f p q in e_univ_select_edges g---- | Sequence of connected vertices to edges.------ > e_path_to_edges "abcd" == [('a','b'),('b','c'),('c','d')]-e_path_to_edges :: [t] -> [EDGE t]-e_path_to_edges = T.adj2 1---- | Undirected edge equality.-e_undirected_eq :: Eq t => EDGE t -> EDGE t -> Bool-e_undirected_eq (a,b) (c,d) = (a == c && b == d) || (a == d && b == c)--elem_by :: (p -> q -> Bool) -> p -> [q] -> Bool-elem_by f = any . f---- | Is the sequence of vertices a path at the graph, ie. are all--- adjacencies in the sequence edges.-e_is_path :: Eq t => [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')-      _ -> True
+ Music/Theory/Graph/Fgl.hs view
@@ -0,0 +1,175 @@+-- | Graph (fgl) functions.+module Music.Theory.Graph.Fgl where++import Control.Monad {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Data.Map as M {- containers -}++import qualified Data.Graph.Inductive.Graph as G {- fgl -}+import qualified Data.Graph.Inductive.Query as G {- fgl -}+import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -}++import qualified Control.Monad.Logic as L {- logict -}++import qualified Music.Theory.Graph.Type as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}++-- | 'T.Lbl' to FGL graph+lbl_to_fgl :: G.Graph gr => T.Lbl v e -> gr v e+lbl_to_fgl (v,e) = let f ((i,j),k) = (i,j,k) in G.mkGraph v (map f e)++-- | Type-specialised.+lbl_to_fgl_gr :: T.Lbl v e -> G.Gr v e+lbl_to_fgl_gr = lbl_to_fgl++-- | FGL graph to 'T.Lbl'+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++-- | 'G.subgraph' of each of 'G.components'.+g_partition :: G.Gr v e -> [G.Gr v e]+g_partition gr = map (`G.subgraph` gr) (G.components gr)++-- | Find first 'G.Node' with given label.+g_node_lookup :: (Eq v,G.Graph gr) => gr v e -> v -> Maybe G.Node+g_node_lookup gr l = fmap fst (find ((== l) . snd) (G.labNodes gr))++-- | Erroring variant.+g_node_lookup_err :: (Eq v,G.Graph gr) => gr v e -> v -> G.Node+g_node_lookup_err gr = fromMaybe (error "g_node_lookup") . g_node_lookup gr++-- | Set of nodes with given labels, plus all neighbours of these nodes.+-- (impl = implications)+ug_node_set_impl :: (Eq v,G.DynGraph gr) => gr v e -> [v] -> [G.Node]+ug_node_set_impl gr nl =+    let n = map (g_node_lookup_err gr) nl+    in nub (sort (n ++ concatMap (G.neighbors gr) n))++-- * Hamiltonian++-- | Node select function, ie. given a graph /g/ and a node /n/ select a set of related nodes from /g/+type G_Node_Sel_f v e = G.Gr v e -> G.Node -> [G.Node]++-- | 'msum' '.' 'map' 'return'.+ml_from_list :: MonadPlus m => [t] -> m t+ml_from_list = msum . map return++-- | Use /sel_f/ of 'G.pre' for directed graphs and 'G.neighbors' for undirected.+g_hamiltonian_path_ml :: (MonadPlus m, L.MonadLogic m) => G_Node_Sel_f v e -> G.Gr v e -> G.Node -> m [G.Node]+g_hamiltonian_path_ml sel_f gr =+    let n_deg = g_degree gr+        recur r c =+            if length r == n_deg - 1+            then return (c:r)+            else do i <- ml_from_list (sel_f gr c)+                    guard (i `notElem` r)+                    recur (c:r) i+    in recur []++-- | 'g_hamiltonian_path_ml' of 'G.neighbors' starting at first node.+--+-- > map (L.observeAll . ug_hamiltonian_path_ml_0) (g_partition gr)+ug_hamiltonian_path_ml_0 :: (MonadPlus m, L.MonadLogic m) => G.Gr v e -> m [G.Node]+ug_hamiltonian_path_ml_0 gr = g_hamiltonian_path_ml G.neighbors gr (G.nodes gr !! 0)++-- * G (from edges)++-- | Edge, no label.+type Edge v = (v,v)++-- | Edge, with label.+type Edge_Lbl v l = (Edge v,l)++-- | Generate a graph given a set of labelled edges.+g_from_edges_l :: (Eq v,Ord v) => [Edge_Lbl v e] -> G.Gr v e+g_from_edges_l e =+    let n = nub (concatMap (\((lhs,rhs),_) -> [lhs,rhs]) e)+        n_deg = length n+        n_id = [0 .. n_deg - 1]+        m = M.fromList (zip n n_id)+        m_get k = M.findWithDefault (error "g_from_edges: m_get") k m+        e' = map (\((lhs,rhs),label) -> (m_get lhs,m_get rhs,label)) e+    in G.mkGraph (zip n_id n) e'++-- | Variant that supplies '()' as the (constant) edge label.+--+-- > let g = G.mkGraph [(0,'a'),(1,'b'),(2,'c')] [(0,1,()),(1,2,())]+-- > in g_from_edges_ul [('a','b'),('b','c')] == g+g_from_edges :: Ord v => [Edge v] -> G.Gr v ()+g_from_edges = let f e = (e,()) in g_from_edges_l . map f++-- * Edges++-- | Label sequence of edges starting at one.+e_label_seq :: [Edge v] -> [Edge_Lbl v Int]+e_label_seq = zipWith (\k e -> (e,k)) [1..]++-- | Normalised undirected labeled edge (ie. order nodes).+e_normalise_l :: Ord v => Edge_Lbl v l -> Edge_Lbl v l+e_normalise_l ((p,q),r) = ((min p q,max p q),r)++-- | Collate labels for edges that are otherwise equal.+e_collate_l :: Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]+e_collate_l = T.collate++-- | 'e_collate_l' of 'e_normalise_l'.+e_collate_normalised_l :: Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]+e_collate_normalised_l = e_collate_l . map e_normalise_l++-- | Apply predicate to universe of possible edges.+e_univ_select_edges :: (t -> t -> Bool) -> [t] -> [Edge t]+e_univ_select_edges f l = [(p,q) | p <- l, q <- l, f p q]++-- | Consider only edges (p,q) where p < q.+e_univ_select_u_edges :: Ord t => (t -> t -> Bool) -> [t] -> [Edge t]+e_univ_select_u_edges f = let g p q = p < q && f p q in e_univ_select_edges g++-- | Sequence of connected vertices to edges.+--+-- > e_path_to_edges "abcd" == [('a','b'),('b','c'),('c','d')]+e_path_to_edges :: [t] -> [Edge t]+e_path_to_edges = T.adj2 1++-- | Undirected edge equality.+e_undirected_eq :: Eq t => Edge t -> Edge t -> Bool+e_undirected_eq (a,b) (c,d) = (a == c && b == d) || (a == d && b == c)++-- | /any/ of /f/.+elem_by :: (p -> q -> Bool) -> p -> [q] -> Bool+elem_by f = any . f++-- | Is the sequence of vertices a path at the graph, ie. are all+-- adjacencies in the sequence edges.+e_is_path :: Eq t => [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')+      _ -> True++-- * Analysis++-- | <https://github.com/ivan-m/Graphalyze/blob/master/Data/Graph/Analysis/Algorithms/Common.hs>+--   Graphalyze has pandoc as a dependency...+pathTree             :: (G.DynGraph g) => G.Decomp g a b -> [[G.Node]]+pathTree (Nothing,_) = []+pathTree (Just ct,g)+    | G.isEmpty g = []+    | null sucs = [[n]]+    | otherwise = (:) [n] . map (n:) . concatMap (subPathTree g') $ sucs+    where+      n = G.node' ct+      sucs = G.suc' ct+      ct' = makeLeaf ct+      g' = ct' G.& g+      subPathTree gr n' = pathTree $ G.match n' gr++-- | Remove all outgoing edges+makeLeaf           :: G.Context a b -> G.Context a b+makeLeaf (p,n,a,_) = (p', n, a, [])+    where p' = filter (\(_,n') -> n' /= n) p
− Music/Theory/Graph/IO.hs 
@@ -1,72 +0,0 @@-{- | IO for graph files, graph6, sparse6 and digraph6 encodings.--<http://users.cecs.anu.edu.au/~bdm/nauty/>-<https://users.cecs.anu.edu.au/~bdm/data/formats.html>--}-module Music.Theory.Graph.IO where--import Data.List.Split {- split -}-import System.Process {- process -}--import qualified Music.Theory.Graph.Type as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}---- * G6 (graph6)---- | Load Graph6 file, discard optional header if present.-g6_load :: FilePath -> IO [String]-g6_load fn = do-  s <- readFile fn-  let s' = if take 6 s == ">>graph6<<" then drop 6 s else s-  return (lines s')---- | Load G6 file variant where each line is "Description\tG6"-g6_dsc_load :: FilePath -> IO [(String,String)]-g6_dsc_load fn = do-  s <- readFile fn-  let r = map (T.split_on_1_err "\t") (lines s)-  return r---- | Call nauty-listg to transform a sequence of G6.---   debian = nauty-g6_to_edg :: [String] -> IO [T.EDG]-g6_to_edg g6 = do-  r <- readProcess "nauty-listg" ["-q","-l0","-e"] (unlines g6)-  return (map T.edg_parse (chunksOf 2 (lines r)))---- | 'T.edg_to_g' of 'g6_to_edg'-g6_to_gr :: [String] -> IO [T.G]-g6_to_gr = fmap (map T.edg_to_g) . g6_to_edg---- | 'g6_to_edg' of 'g6_dsc_load'.-g6_dsc_load_edg :: FilePath -> IO [(String,T.EDG)]-g6_dsc_load_edg fn = do-  dat <- g6_dsc_load fn-  let (dsc,g6) = unzip dat-  gr <- g6_to_edg g6-  return (zip dsc gr)---- | 'T.edg_to_g' of 'g6_dsc_load_edg'-g6_dsc_load_gr :: FilePath -> IO [(String,T.G)]-g6_dsc_load_gr = fmap (map (\(dsc,e) -> (dsc,T.edg_to_g e))) . g6_dsc_load_edg--{- | Generate the text format read by nauty-amtog.--> e = ((4,3),[(0,3),(1,3),(2,3)])-> m = T.edg_to_adj_mtx_undir e-> putStrLn (adj_mtx_to_am m)---}-adj_mtx_to_am :: T.ADJ_MTX -> String-adj_mtx_to_am (nv,mtx) =-  unlines ["n=" ++ show nv-          ,"m"-          ,unlines (map (unwords . map show) mtx)]---- | Call nauty-amtog to transform a sequence of ADJ_MTX to G6.------ > adj_mtx_to_g6 [m,m]-adj_mtx_to_g6 :: [T.ADJ_MTX] -> IO [String]-adj_mtx_to_g6 adj = do-  r <- readProcess "nauty-amtog" ["-q"] (unlines (map adj_mtx_to_am adj))-  return (lines r)
Music/Theory/Graph/Johnson_2014.hs view
@@ -11,20 +11,21 @@ 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.Combinations as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Tuple as T {- hmt-base -}+ import qualified Music.Theory.Graph.Dot as T {- hmt -}-import qualified Music.Theory.Graph.FGL 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.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 -}+import qualified Music.Theory.Z.Tto as T {- hmt -}+import qualified Music.Theory.Z.Sro as T {- hmt -}  -- * Common @@ -74,7 +75,7 @@ -- > min_vl [6,11,13] [6,10,14] == 2 min_vl :: (Num a,Ord a) => [a] -> [a] -> a min_vl p q =-    let f x = sum (map absdif (zip p x))+    let f x = sum (zipWith (curry absdif) p x)     in minimum (map f (permutations q))  min_vl_of :: (Num a, Ord a) => a -> [a] -> [a] -> Bool@@ -89,7 +90,7 @@ 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 :: 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@@ -118,7 +119,7 @@  -- * Graph -oh_def_opt :: [T.DOT_META_ATTR]+oh_def_opt :: [T.Dot_Meta_Attr] oh_def_opt =   [("graph:layout","neato")   ,("graph:epsilon","0.000001")@@ -126,19 +127,19 @@   ,("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 :: Ord v => [T.Dot_Meta_Attr] -> T.Graph_Pp v e -> [T.Edge_Lbl 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 :: 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 :: Ord v => String -> (v -> String) -> [T.Edge v] -> [String] gen_graph_ul_ty ty = gen_graph_ul [("graph:layout",ty)] -gen_flt_graph_pp :: Ord t => [T.DOT_META_ATTR] -> ([t] -> String) -> ([t] -> [t] -> Bool) -> [[t]] -> [String]+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 :: (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@@ -164,7 +165,7 @@         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 :: (T.Edge v -> l) -> [T.Edge v] -> [T.Edge_Lbl v l] e_add_label f = let g (p,q) = ((p,q),f (p,q)) in map g  p12_c5_gr :: [String]@@ -201,7 +202,7 @@  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)+  let pc_to_key m pc = let (n,a) = fromMaybe (error "p14_mk_e?") (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 @@ -220,7 +221,7 @@       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 :: [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@@ -256,7 +257,7 @@         f _ = error "p14_gen_tonnetz_e"     in mapMaybe f . T.combinations 2 . p14_gen_tonnetz_n n k --- NEO-RIEMANNIAN TONNETTZ+-- Neo-Riemannian Tonnettz p14_nrt_gr :: [String] p14_nrt_gr =   let e = p14_gen_tonnetz_e 3 [7,9,16] [48]@@ -264,7 +265,7 @@           ,("node:fontsize","10")           ,("node:fontname","century schoolbook")           ,("edge:len","1")]-      pp = (\(_,v) -> [("label",T.pc_pp (T.z_mod T.z12 v))],\_ -> [])+      pp = (\(_,v) -> [("label",T.pc_pp (T.z_mod T.z12 v))],const [])   in gen_graph o pp e  -- * P.31@@ -283,7 +284,7 @@ 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 :: Show t => t -> [T.Dot_Meta_Attr] p114_mk_o el =   [("node:shape","box")   ,("edge:len",show el)@@ -291,7 +292,7 @@  p114_mk_gr :: Double -> ([Z12] -> [Z12] -> Bool) -> [String] p114_mk_gr el flt =-  let n = (map sort (T.z_sro_ti_related T.z12 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@@ -326,7 +327,7 @@ p125_gr :: [String] p125_gr =     let t :: [[Int]]-        t = [[p,q,r] | p <- [0 .. 11], q <- [0 .. 11], r <- [0 ..11], q > p, r > q]+        t = [[p,q,r] | p <- [0 .. 11], q <- [0 .. 11], q > p, r <- [0 ..11], r > q]         c = T.collate (zip (map sum t) t)         with_h n = lookup n c         ch = fromJust (liftM2 (++) (with_h 15) (with_h 16))@@ -337,7 +338,7 @@ p131_gr :: [String] p131_gr =     let c = let u = [6::Int .. 14]-            in [[p,q,r] | p <- u, q <- u, r <- u, q > p, r > q, p + q + r == 30]+            in [[p,q,r] | p <- u, q <- u, q > p, r <- u, r > q, p + q + r == 30]     in gen_graph_ul [] set_pp (T.e_univ_select_u_edges (min_vl_of 2) c)  -- * P.148@@ -373,7 +374,7 @@   in filter ((== 1) . (`mod` 4) . sum) c  -- > length p162_e == 47-p162_e :: [T.EDGE [Int]]+p162_e :: [T.Edge [Int]] p162_e = T.e_univ_select_u_edges (doi_of 3) p162_ch  p162_gr :: [String]@@ -393,7 +394,7 @@ 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 :: [T.Edge Int] p172_nd_e_set_alt = concatMap (T.e_path_to_edges . T.close 1) p172_cyc0  p172_gr :: G.Gr () ()@@ -406,7 +407,7 @@ -- > (length c0,length c1) == (48,48) p172_all_cyc :: ([[Int]], [[Int]]) p172_all_cyc =-    let [a,b] = T.g_partition p172_gr+    let (a, b) = T.firstSecond (T.g_partition p172_gr)     in (L.observeAll (T.ug_hamiltonian_path_ml_0 a)        ,L.observeAll (T.ug_hamiltonian_path_ml_0 b)) @@ -424,15 +425,15 @@   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+-- | '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+-- | '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 :: 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 ..])@@ -443,14 +444,14 @@ -- -- > 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 :: 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 :: [[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 :: (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]@@ -570,7 +571,7 @@ 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 :: [T.Dot_Meta_Attr] p201_o =   [("graph:splines","false")   ,("node:shape","box")
− Music/Theory/Graph/LCF.hs 
@@ -1,109 +0,0 @@-{- | LCF (Lederberg/Coxeter/Frucht) notation--The notation only applies to Hamiltonian graphs, since it achieves its-symmetry and conciseness by placing a Hamiltonian cycle in a circular-embedding and then connecting specified pairs of nodes with edges. (EW)---}-module Music.Theory.Graph.LCF where--import Data.Complex {- base -}-import Data.List {- base -}--import qualified Music.Theory.Graph.Type as T {- hmt -}--type LCF = ([Int],Int)-type R = Double--lcf_seq :: LCF -> [Int]-lcf_seq (l,k) = concat (replicate k l)--lcf_degree :: LCF -> Int-lcf_degree (l,k) = length l * k---- | LCF to edge list.-lcf_to_edg :: LCF -> T.EDG-lcf_to_edg (l,k) =-  let v_n = length l * k-      add i j = (i + j) `mod` v_n-      v = [0 .. v_n - 1]-  in ((v_n,v_n + (v_n `div` 2))-     ,concat [[(i,i `add` 1) | i <- v]-             ,nub (sort (map T.e_sort (zip v (zipWith add v (lcf_seq (l,k))))))])---- | LCF edge-list to graph labeled with circular co-ordinates.-edg_circ_gr :: R -> T.EDG -> T.LBL (R,R) ()-edg_circ_gr rad ((n,_),e) =-  let polar_to_rectangular (mg,ph) = let c = mkPolar mg ph in (realPart c,imagPart c)-      ph_incr = (2 * pi) / fromIntegral n-      v = zip [0 .. n - 1] (map polar_to_rectangular (zip (repeat rad) [0, ph_incr ..]))-  in (v,zip e (repeat ()))--{- | LCF graph set given at <http://mathworld.wolfram.com/LCFNotation.html>--> length lcf_mw_set == 57-> length (nub (map snd lcf_mw_set)) == 57 -- IE. UNIQ--}-lcf_mw_set :: [(String, LCF)]-lcf_mw_set =-  [("Tetrahedral graph",([2,-2],2)) -- ([2],4)-  ,("Utility graph",([3],6)) -- ([3,-3],3)-  ,("3-prism graph",([-3,-2,2],2))-  ,("Cubical graph",([3,-3],4))-  ,("Wagner graph",([4],8))-  ,("3-matchstick graph",([-2,-2,2,2],2))-  ,("4-Möbius ladder",([-4],8))-  ,("5-Möbius ladder",([-5],10))-  ,("5-prism graph",([-5,3,-4,4,-3],2))-  ,("Bidiakis cube",([6,4,-4],4))-  ,("Franklin graph",([5,-5],6))-  ,("Frucht graph",([-5,-2,-4,2,5,-2,2,5,-2,-5,4,2],1))-  ,("Truncated tetrahedral graph",([2,6,-2],4))-  ,("Generalized Petersen graph (6,2)",([-5,2,4,-2,-5,4,-4,5,2,-4,-2,5],1))-  ,("6-Möbius ladder",([-6],12))-  ,("6-prism graph",([-3,3],6))-  ,("Heawood graph",([5,-5],7))-  ,("Generalized Petersen graph (7,2)",([-7,-5,4,-6,-5,4,-4,-7,4,-4,5,6,-4,5],1))-  ,("7-Möbius ladder",([-7],14))-  ,("7-prism graph",([-7,5,3,-6,6,-3,-5],2))-  ,("Cubic vertex-transitive graph Ct19",([-7,7],8))-  ,("Möbius-Kantor graph",([5,-5],8))-  ,("8-Möbius ladder",([-8],16))-  ,("8-prism graph",([-3,3],8))-  ,("Pappus graph",([5,7,-7,7,-7,-5],3))-  ,("Cubic vertex-transitive graph Ct20",([-7,7],9)) -- ([5,-5],9)-  ,("Cubic vertex-transitive graph Ct23",([-9,-2,2],6))-  ,("Generalized Petersen graph (9,2)",([-9,-8,-4,-9,4,8],3))-  ,("Generalized Petersen graph (9,3)",([-9,-6,2,5,-2,-9,5,-9,-5,-9,2,-5,-2,6,-9,2,-9,-2],1))-  ,("9-Möbius ladder",([-9],18))-  ,("9-prism graph",([-9,7,5,3,-8,8,-3,-5,-7],2))-  ,("Desargues graph",([5,-5,9,-9],5))-  ,("Dodecahedral graph",([10,7,4,-4,-7,10,-4,7,-7,4],2))-  ,("Cubic vertex-transitive graph Ct25",([-7,7],10))-  ,("Cubic vertex-transitive graph Ct28",([-6,-6,6,6],5))-  ,("Cubic vertex-transitive graph Ct29",([-9,9],10))-  ,("Generalized Petersen graph (10,4)",([-10,-7,5,-5,7,-6,-10,-5,5,6],2))-  ,("Largest cubic nonplanar graph with diameter 3",([-10,-7,-5,4,7,-10,-7,-4,5,7,-10,-7,6,-5,7,-10,-7,5,-6,7],1))-  ,("10-Möbius ladder",([-10],20))-  ,("10-prism graph",([-3,3],10))-  ,("McGee graph",([12,7,-7],8))-  ,("Truncated cubical graph",([2,9,-2,2,-9,-2],4))-  ,("Truncated octahedral graph",([3,-7,7,-3],6))-  ,("Nauru graph",([5,-9,7,-7,9,-5],4))-  ,("F26A graph",([-7,7],13))-  ,("Tutte-Coxeter graph",([-13,-9,7,-7,9,13],5))-  ,("Dyck graph",([5,-5,13,-13],8))-  ,("Gray graph",([-25,7,-7,13,-13,25],9))-  ,("Truncated dodecahedral graph",([30,-2,2,21,-2,2,12,-2,2,-12,-2,2,-21,-2,2,30,-2,2,-12,-2,2,21,-2,2,-21,-2,2,12,-2,2],2))-  ,("Harries graph",([-29,-19,-13,13,21,-27,27,33,-13,13,19,-21,-33,29],5))-  ,("Harries-Wong graph",([9,25,31,-17,17,33,9,-29,-15,-9,9,25,-25,29,17,-9,9,-27,35,-9,9,-17,21,27,-29,-9,-25,13,19,-9,-33,-17,19,-31,27,11,-25,29,-33,13,-13,21,-29,-21,25,9,-11,-19,29,9,-27,-19,-13,-35,-9,9,17,25,-9,9,27,-27,-21,15,-9,29,-29,33,-9,-25],1))-  ,("Balaban 10-cage",([-9,-25,-19,29,13,35,-13,-29,19,25,9,-29,29,17,33,21,9,-13,-31,-9,25,17,9,-31,27,-9,17,-19,-29,27,-17,-9,-29,33,-25,25,-21,17,-17,29,35,-29,17,-17,21,-25,25,-33,29,9,17,-27,29,19,-17,9,-27,31,-9,-17,-25,9,31,13,-9,-21,-33,-17,-29,29],1))-  ,("Foster graph",([17,-9,37,-37,9,-17],15))-  ,("Biggs-Smith graph",([16,24,-38,17,34,48,-19,41,-35,47,-20,34,-36,21,14,48,-16,-36,-43,28,-17,21,29,-43,46,-24,28,-38,-14,-50,-45,21,8,27,-21,20,-37,39,-34,-44,-8,38,-21,25,15,-34,18,-28,-41,36,8,-29,-21,-48,-28,-20,-47,14,-8,-15,-27,38,24,-48,-18,25,38,31,-25,24,-46,-14,28,11,21,35,-39,43,36,-38,14,50,43,36,-11,-36,-24,45,8,19,-25,38,20,-24,-14,-21,-8,44,-31,-38,-28,37],1))-  ,("Balaban 11-cage",([44,26,-47,-15,35,-39,11,-27,38,-37,43,14,28,51,-29,-16,41,-11,-26,15,22,-51,-35,36,52,-14,-33,-26,-46,52,26,16,43,33,-15,17,-53,23,-42,-35,-28,30,-22,45,-44,16,-38,-16,50,-55,20,28,-17,-43,47,34,-26,-41,11,-36,-23,-16,41,17,-51,26,-33,47,17,-11,-20,-30,21,29,36,-43,-52,10,39,-28,-17,-52,51,26,37,-17,10,-10,-45,-34,17,-26,27,-21,46,53,-10,29,-50,35,15,-47,-29,-41,26,33,55,-17,42,-26,-36,16],1))-  ,("Ljubljana graph",([47,-23,-31,39,25,-21,-31,-41,25,15,29,-41,-19,15,-49,33,39,-35,-21,17,-33,49,41,31,-15,-29,41,31,-15,-25,21,31,-51,-25,23,9,-17,51,35,-29,21,-51,-39,33,-9,-51,51,-47,-33,19,51,-21,29,21,-31,-39],2))-  ,("Tutte 12-cage",([17,27,-13,-59,-35,35,-11,13,-53,53,-27,21,57,11,-21,-57,59,-17],7))]---- Local Variables:--- truncate-lines:t--- End:
− Music/Theory/Graph/OBJ.hs 
@@ -1,100 +0,0 @@-{- | Graph/OBJ functions--This module is primarily for reading & writing graphs where vertices are labeled (x,y,z) to OBJ files.--PDF=<http://www.cs.utah.edu/~boulos/cs3505/obj_spec.pdf>-TXT=<http://www.martinreddy.net/gfx/3d/OBJ.spec>--}-module Music.Theory.Graph.OBJ where--import Data.Either {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}--import qualified Music.Theory.Graph.Type as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Show as T {- hmt -}--{- | Requires (but does not check) that graph vertices be indexed [0 .. #v - 1]-OBJ file vertices are one-indexed.-If /wr_p/ is True point (p) entries are written.--}-v3_graph_to_obj_opt :: RealFloat n => Bool -> Int -> T.LBL (n,n,n) () -> [String]-v3_graph_to_obj_opt wr_p k (v,e) =-  let v_pp (_,(x,y,z)) = unwords ("v" : map (T.realfloat_pp k) [x,y,z])-      e_pp ((i,j),()) = unwords ("l" : map show [i + 1,j + 1])-  in concat [map v_pp v-            ,if wr_p then map (\i -> "p " ++ show i) [1 .. length v] else []-            ,map e_pp e]---- | 'v3_graph_to_obj_opt' 'False'.-v3_graph_to_obj :: RealFloat n => Int -> T.LBL (n,n,n) () -> [String]-v3_graph_to_obj = v3_graph_to_obj_opt False---- | 'writeFile' of 'v3_graph_to_obj'.-obj_store_v3_graph :: RealFloat n => Int -> FilePath -> (T.LBL (n,n,n) ()) -> IO ()-obj_store_v3_graph k fn = writeFile fn . unlines . v3_graph_to_obj k---- | Read OBJ file consisting only of /v/, /l/ and /f/ (and optionally /p/, which are ignored) entries.-obj_to_v3_graph :: Read n => [String] -> T.LBL (n,n,n) ()-obj_to_v3_graph txt =-  let l_verify (i,j) = if i < 0 || j < 0 then error "obj_to_v3_graph?" else (i,j)-      e_read (i,j) = l_verify (read i - 1,read j - 1)-      f s = case words s of-              ["v",x,y,z] -> Just (Left (read x,read y,read z))-              "l":ix -> Just (Right (map e_read (T.adj2 1 ix)))-              "f":ix -> Just (Right (map e_read (T.adj2_cyclic 1 ix)))-              ["p",_] -> Nothing-              _ -> error "obj_to_v3_graph?"-      (v,l) = partitionEithers (mapMaybe f txt)-  in (zip [0..] v,zip (concat l) (repeat ()))---- | 'obj_to_v3_graph' of 'readFile'.-obj_load_v3_graph :: Read n => FilePath -> IO (T.LBL (n,n,n) ())-obj_load_v3_graph = fmap (obj_to_v3_graph . lines) . readFile---- * F64---- | Type-specialised.-v3_graph_to_obj_f64 :: Int -> T.LBL (Double,Double,Double) () -> [String]-v3_graph_to_obj_f64 = v3_graph_to_obj---- | Type-specialised.-obj_store_v3_graph_f64 :: Int -> FilePath -> (T.LBL (Double,Double,Double) ()) -> IO ()-obj_store_v3_graph_f64 = obj_store_v3_graph---- | Type-specialised.-obj_load_v3_graph_f64 :: FilePath -> IO (T.LBL (Double,Double,Double) ())-obj_load_v3_graph_f64 = obj_load_v3_graph---- * FACES---- | Rewrite a set of faces (CCW triples of (x,y,z) coordinates) as (vertices,[[v-indices]]).---   Vertices are zero-indexed.-obj_face_set_dat :: Ord n => [[(n,n,n)]] -> ([(n,n,n)],[[Int]])-obj_face_set_dat t =-  let v = nub (sort (concat t))-      v_ix = zip [0..] v-      f = map (map (flip T.reverse_lookup_err v_ix)) t-  in (v,f)---- | Inverse of 'obj_face_set_dat'.-obj_face_dat_set :: ([(n,n,n)],[[Int]]) -> [[(n,n,n)]]-obj_face_dat_set (v,f) = map (map (flip T.lookup_err (zip [0..] v))) f--obj_face_dat_fmt :: (Show n, Ord n) => ([(n,n,n)],[[Int]]) -> [String]-obj_face_dat_fmt (v,f) =-  let v_f (x,y,z) = unwords ["v",show x,show y,show z]-      f_f = unwords . ("f" :) . map show . map (+ 1)-  in map v_f v ++ map f_f f--obj_face_dat_store :: (Show n, Ord n) => FilePath -> ([(n,n,n)],[[Int]]) -> IO ()-obj_face_dat_store fn = writeFile fn . unlines . obj_face_dat_fmt---- | Format 'obj_face_set_dat' as an OBJ file. OBJ files are one-indexed.-obj_face_set_fmt :: (Show n, Ord n) => [[(n,n,n)]] -> [String]-obj_face_set_fmt = obj_face_dat_fmt . obj_face_set_dat---- | 'writeFile' of 'obj_face_set_fmt'-obj_face_set_store :: (Show n, Ord n) => FilePath -> [[(n,n,n)]] -> IO ()-obj_face_set_store fn = writeFile fn . unlines . obj_face_set_fmt
− Music/Theory/Graph/PLY.hs 
@@ -1,87 +0,0 @@-{- | Graph/PLY functions.--This module is used instead of 'Music.Theory.Graph.OBJ' when edges are coloured.--There is no reader.--Greg Turk "The PLY Polygon File Format" (1994)--SEE "PLY_FILES.txt" in <https://www.cc.gatech.edu/projects/large_models/files/ply.tar.gz>---}-module Music.Theory.Graph.PLY where--import Data.List {- base -}--import qualified Music.Theory.Graph.Type as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Show as T {- hmt -}---- | ASCII PLY-1.0 header for V3 graph of (#v,#e).---   Edges and faces are (r,g,b) coloured.------ > putStrLn $ unlines $ ply_header (8,6,0)-ply_header :: (Int,Int,Int) -> [String]-ply_header (n_v,n_f,n_e) =-  concat-  [["ply"-   ,"format ascii 1.0"-   ,"element vertex " ++ show n_v-   ,"property float x"-   ,"property float y"-   ,"property float z"]-  ,if n_f > 0-   then ["element face " ++ show n_f-        ,"property list uchar int vertex_index"-        ,"property uchar red"-        ,"property uchar green"-        ,"property uchar blue"]-   else []-  ,if n_e > 0-   then ["element edge " ++ show n_e-        ,"property int vertex1"-        ,"property int vertex2"-        ,"property uchar red"-        ,"property uchar green"-        ,"property uchar blue"]-   else []-  ,["end_header"]]--{- | Requires (but does not check) that graph vertices be indexed [0 .. #v - 1]-     Edges are coloured as U8 (red,green,blue) triples.-     It is an error (not checked) for there to be no edges.-     PLY files are zero-indexed.--}-v3_graph_to_ply_clr :: Int -> T.LBL (Double,Double,Double) (Int,Int,Int) -> [String]-v3_graph_to_ply_clr k (v,e) =-  let v_pp (_,(x,y,z)) = unwords (map (T.double_pp k) [x,y,z])-      e_pp ((i,j),(r,g,b)) = unwords (map show [i,j,r,g,b])-  in concat [ply_header (length v,0,length e)-            ,map v_pp v-            ,map e_pp e]---- * FACES---- | Rewrite a set of faces as (vertices,[[v-indices]]).---   Indices are zero-indexed.-ply_face_set_dat :: Ord n => [([(n,n,n)],(i,i,i))] -> ([(Int,(n,n,n))],[([Int],(i,i,i))])-ply_face_set_dat t =-  let p = nub (sort (concat (map fst t)))-      c = map snd t-      v = zip [0..] p-      f = map (map (flip T.reverse_lookup_err v)) (map fst t)-  in (v,zip f c)---- | Format a set of coloured faces as an PLY file.---    (CCW triples of (x,y,z) coordinates, (r,g,b) colour)---   PLY files are one-indexed.-ply_face_set_fmt :: (Show n, Ord n,Show i) => [([(n,n,n)],(i,i,i))] -> [String]-ply_face_set_fmt t =-  let v_f (_,(x,y,z)) = unwords [show x,show y,show z]-      f_f (ix,(r,g,b)) = unwords (map show (length ix : ix) ++ map show [r,g,b])-      (v,f) = ply_face_set_dat t-  in concat [ply_header (length v,length f,0), map v_f v, map f_f f]---- | 'writeFile' of 'ply_face_set_fmt'-ply_face_set_store :: (Show n, Ord n,Show i) => FilePath -> [([(n,n,n)],(i,i,i))] -> IO ()-ply_face_set_store fn = writeFile fn . unlines . ply_face_set_fmt
− Music/Theory/Graph/Type.hs 
@@ -1,235 +0,0 @@--- | Graph types.-module Music.Theory.Graph.Type where--import Data.Bifunctor {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}--import qualified Data.Graph as G {- containers -}--import qualified Music.Theory.List as T {- hmt -}---- * Type parameterised graph---- | (vertices,edges)-type GR t = ([t],[(t,t)])---- | 'GR' is a functor.-gr_map :: (t -> u) -> GR t -> GR u-gr_map f (v,e) = (map f v,map (bimap f f) e)---- | (|V|,|E|)-gr_degree :: GR t -> (Int,Int)-gr_degree (v,e) = (length v,length e)---- | Re-label graph given table.-gr_relabel :: Eq t => [(t,u)] -> GR t -> GR u-gr_relabel tbl (v,e) =-  let get z = T.lookup_err z tbl-  in (map get v,map (\(p,q) -> (get p,get q)) e)---- | Un-directed edge equality.------ > e_eq_undir (0,1) (1,0) == True-e_eq_undir :: Eq t => (t,t) -> (t,t) -> Bool-e_eq_undir e0 e1 =-  let swap (i,j) = (j,i)-  in e0 == e1 || e0 == swap e1---- | Sort edge.------ > map e_sort [(0,1),(1,0)] == [(0,1),(0,1)]-e_sort :: Ord t => (t, t) -> (t, t)-e_sort (i,j) = (min i j,max i j)---- | If (i,j) and (j,i) are both in E delete (j,i) where i < j.-gr_mk_undir :: Ord t => GR t -> GR t-gr_mk_undir (v,e) = (v,nub (sort (map e_sort e)))---- | List of E to G, derives V from E.-eset_to_gr :: Ord t => [(t,t)] -> GR t-eset_to_gr e =-  let v = sort (nub (concatMap (\(i,j) -> [i,j]) e))-  in (v,e)---- | Sort v and e.-gr_sort :: Ord t => GR t -> GR t-gr_sort (v,e) = (sort v,sort e)---- * Int graph---- | Vertex-type V = Int---- | Edge-type E = (V,V)---- | (vertices,edges)-type G = GR V---- | 'G.Graph' to 'G'.-graph_to_g :: G.Graph -> G-graph_to_g gr = (G.vertices gr,G.edges gr)---- | 'G' to 'G.Graph'------ > g = ([0,1,2],[(0,1),(0,2),(1,2)])--- > g == gr_sort (graph_to_g (g_to_graph g))-g_to_graph :: G -> G.Graph-g_to_graph (v,e) = G.buildG (minimum v,maximum v) e---- | Unlabel graph, make table.-gr_unlabel :: Eq t => GR t -> (G,[(V,t)])-gr_unlabel (v,e) =-  let n = length v-      v' = [0 .. n - 1]-      tbl = zip v' v-      get k = T.reverse_lookup_err k tbl-      e' = map (\(p,q) -> (get p,get q)) e-  in ((v',e'),tbl)---- | 'g_to_graph' of 'gr_unlabel'.------ > gr = ("abc",[('a','b'),('a','c'),('b','c')])--- > (g,tbl) = gr_to_graph gr-gr_to_graph :: Eq t => GR t -> (G.Graph,[(V,t)])-gr_to_graph gr =-  let ((v,e),tbl) = gr_unlabel gr-  in (G.buildG (0,length v - 1) e,tbl)---- * EDG = edge list (zero-indexed)---- | ((|V|,|E|),[E])-type EDG = ((Int,Int), [E])---- | Requires V is (0 .. |v| - 1).-edg_to_g :: EDG -> G-edg_to_g ((nv,ne),e) =-  let v = [0 .. nv - 1]-  in if ne /= length e-     then error (show ("edg_to_g",nv,ne,length e))-     else (v,e)---- | Parse EDG as printed by nauty-listg.-edg_parse :: [String] -> EDG-edg_parse ln =-  let parse_int_list = map read . words-      parse_int_pairs = T.adj2 2 . parse_int_list-      parse_int_pair = T.unlist1_err . parse_int_pairs-  in case ln of-       [m,e] -> (parse_int_pair m,parse_int_pairs e)-       _ -> error "edg_parse"---- * Adjacencies---- | Adjacency list-type ADJ t = [(t,[t])]---- | ADJ to G.-adj_to_gr :: Ord t => ADJ t -> GR t-adj_to_gr adj =-  let e = concatMap (\(i,j) -> zip (repeat i) j) adj-  in eset_to_gr e---- | G to ADJ.-gr_to_adj :: Ord t => (t -> (t,t) -> Maybe t) -> GR t -> ADJ t-gr_to_adj sel_f (v,e) =-  let f k = (k,sort (mapMaybe (sel_f k) e))-  in filter (\(_,a) -> a /= []) (map f v)---- | Directed graph to ADJ.------ > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])--- > r = [(0,[1,3]),(2,[1]),(3,[0])]--- > gr_to_adj_dir g == r-gr_to_adj_dir :: Ord t => GR t -> ADJ t-gr_to_adj_dir =-  let sel_f k (i,j) = if i == k then Just j else Nothing-  in gr_to_adj sel_f---- | Un-directed graph to ADJ.------ > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])--- > gr_to_adj_undir g == [(0,[1,3,3]),(1,[2])]-gr_to_adj_undir :: Ord t => GR t -> ADJ t-gr_to_adj_undir =-  let sel_f k (i,j) =-        if i == k && j >= k-        then Just j-        else if j == k && i >= k-             then Just i-             else Nothing-  in gr_to_adj sel_f---- | Adjacency matrix, (|v|,mtx)-type ADJ_MTX = (Int,[[Int]])--{- | EDG to ADJ_MTX for un-directed graph.--> e = ((4,3),[(0,3),(1,3),(2,3)])-> edg_to_adj_mtx_undir e == [[0,0,0,1],[0,0,0,1],[0,0,0,1],[1,1,1,0]]--> e = ((4,4),[(0,1),(0,3),(1,2),(2,3)])-> edg_to_adj_mtx_undir e == [[0,1,0,1],[1,0,1,0],[0,1,0,1],[1,0,1,0]]---}-edg_to_adj_mtx_undir :: EDG -> ADJ_MTX-edg_to_adj_mtx_undir ((nv,_ne),e) =-  let v = [0 .. nv - 1]-      f i j = case find (e_eq_undir (i,j)) e of-                Nothing -> 0-                _ -> 1-  in (nv,map (\i -> map (f i) v) v)---- * Labels---- | Labelled graph, distinct vertex and edge labels.-type LBL_GR v v_lbl e_lbl = ([(v,v_lbl)],[((v,v),e_lbl)])---- | Labelled graph, V/E typed.-type LBL v e = LBL_GR V v e--lbl_degree :: LBL v e -> (Int,Int)-lbl_degree (v,e) = (length v,length e)---- | Apply /v/ at vertex labels and /e/ at edge labels.-lbl_bimap :: (v -> v') -> (e -> e') -> LBL v e -> LBL v' e'-lbl_bimap v_f e_f (v,e) = (map (fmap v_f) v,map (fmap e_f) e)--v_label :: v -> LBL v e -> V -> v-v_label def (tbl,_) v = fromMaybe def (lookup v tbl)--v_label_err :: LBL v e -> V -> v-v_label_err = v_label (error "v_label")--e_label :: e -> LBL v e -> E -> e-e_label def (_,tbl) e = fromMaybe def (lookup e tbl)--e_label_err :: LBL v e -> E -> e-e_label_err = e_label (error "e_label")--lbl_gr_to_lbl :: Eq v => LBL_GR v v_lbl e_lbl -> LBL v_lbl e_lbl-lbl_gr_to_lbl (v,e) =-  let n = length v-      v' = [0 .. n - 1]-      tbl = zip v' (map fst v)-      get k = T.reverse_lookup_err k tbl-      e' = map (\((p,q),r) -> ((get p,get q),r)) e-  in (zip v' (map snd v),e')---- > gr_to_lbl ("ab",[('a','b')]) == ([(0,'a'),(1,'b')],[((0,1),('a','b'))])-gr_to_lbl :: Eq t => GR t -> LBL t (t,t)-gr_to_lbl (v,e) = lbl_gr_to_lbl (zip v v,zip e e)--lbl_delete_edge_labels :: LBL v e -> LBL v ()-lbl_delete_edge_labels (v,e) = (v,map (\(x,_) -> (x,())) e)--gr_to_lbl_ :: Eq t => GR t -> LBL t ()-gr_to_lbl_ = lbl_delete_edge_labels . gr_to_lbl---- | Construct LBL from set of E, derives V from E.-eset_to_lbl :: Ord t => [(t,t)] -> LBL t ()-eset_to_lbl e =-  let v = nub (sort (concatMap (\(i,j) -> [i,j]) e))-      get_ix z = fromMaybe (error "eset_to_lbl") (elemIndex z v)-  in (zip [0..] v, map (\(i,j) -> ((get_ix i,get_ix j),())) e)
− Music/Theory/IO.hs 
@@ -1,34 +0,0 @@--- | "System.IO" related functions.-module Music.Theory.IO where--import qualified Data.ByteString as B {- bytestring -}-import qualified Data.Text as T {- text -}-import qualified Data.Text.Encoding as T {- text -}-import qualified Data.Text.IO as T {- text -}-import qualified System.Directory as D {- directory -}---- | 'T.decodeUtf8' of 'B.readFile'.-read_file_utf8_text :: FilePath -> IO T.Text-read_file_utf8_text = fmap T.decodeUtf8 . B.readFile---- | Read (strictly) a UTF-8 encoded text file, implemented via "Data.Text".-read_file_utf8 :: FilePath -> IO String-read_file_utf8 = fmap T.unpack . read_file_utf8_text---- | 'read_file_utf8', or a default value if the file doesn't exist.-read_file_utf8_or :: String -> FilePath -> IO String-read_file_utf8_or def f = do-  x <- D.doesFileExist f-  if x then read_file_utf8 f else return def---- | Write UTF8 string as file, via "Data.Text".-write_file_utf8 :: FilePath -> String -> IO ()-write_file_utf8 fn = B.writeFile fn . T.encodeUtf8 . T.pack---- | 'readFile' variant using 'Text' for @ISO 8859-1@ (Latin 1) encoding.-read_file_iso_8859_1 :: FilePath -> IO String-read_file_iso_8859_1 = fmap (T.unpack . T.decodeLatin1) . B.readFile---- | 'readFile' variant using 'Text' for local encoding.-read_file_locale :: FilePath -> IO String-read_file_locale = fmap T.unpack . T.readFile
Music/Theory/Instrument/Names.hs view
@@ -2,7 +2,7 @@  import Data.List.Split {- split -} --- (family,abbreviations,names,transpositions)+-- | (family,abbreviations,names,transpositions) instrument_db' :: [(String,String,String,String)] instrument_db' =     [("br","b.tbn","bass trombone","")@@ -106,7 +106,7 @@     ,("ww","oca","ocarina","")     ] --- (family,[abbreviations],[names],[transpositions])+-- | (family,[abbreviations],[names],[transpositions]) instrument_db :: [(String,[String],[String],[String])] instrument_db =     let sep = splitOn ";"
Music/Theory/Interval.hs view
@@ -4,17 +4,17 @@ import Data.List {- base -} import Data.Maybe {- base -} -import qualified Music.Theory.Ord as T-import qualified Music.Theory.Pitch as T-import qualified Music.Theory.Pitch.Note as T+import qualified Music.Theory.Ord as T {- hmt -}+import qualified Music.Theory.Pitch as T {- hmt -}+import qualified Music.Theory.Pitch.Note as T {- hmt -}  -- | Interval type or degree.-data Interval_T = Unison | Second | Third | Fourth+data Interval_Type = Unison | Second | Third | Fourth                 | Fifth | Sixth | Seventh                   deriving (Eq,Enum,Bounded,Ord,Show)  -- | Interval quality.-data Interval_Q = Diminished | Minor+data Interval_Quality = Diminished | Minor                 | Perfect                 | Major | Augmented                   deriving (Eq,Enum,Bounded,Ord,Show)@@ -22,23 +22,23 @@ -- | Common music notation interval.  An 'Ordering' of 'LT' indicates -- an ascending interval, 'GT' a descending interval, and 'EQ' a -- unison.-data Interval = Interval {interval_type :: Interval_T-                         ,interval_quality :: Interval_Q+data Interval = Interval {interval_type :: Interval_Type+                         ,interval_quality :: Interval_Quality                          ,interval_direction :: Ordering                          ,interval_octave :: T.Octave}                 deriving (Eq,Show) --- | Interval type between 'Note_T' values.+-- | Interval type between 'Note' values. -- -- > map (interval_ty C) [E,B] == [Third,Seventh]-interval_ty :: T.Note_T -> T.Note_T -> Interval_T+interval_ty :: T.Note -> T.Note -> Interval_Type interval_ty n1 n2 = toEnum ((fromEnum n2 - fromEnum n1) `mod` 7) --- | Table of interval qualities.  For each 'Interval_T' gives--- directed semitone interval counts for each allowable 'Interval_Q'.+-- | Table of interval qualities.  For each 'Interval_Type' gives+-- directed semitone interval counts for each allowable 'Interval_Quality'. -- For lookup function see 'interval_q', for reverse lookup see -- 'interval_q_reverse'.-interval_q_tbl :: Integral n => [(Interval_T, [(n,Interval_Q)])]+interval_q_tbl :: Integral n => [(Interval_Type, [(n,Interval_Quality)])] interval_q_tbl =     [(Unison,[(11,Diminished)              ,(0,Perfect)@@ -66,20 +66,20 @@               ,(11,Major)               ,(12,Augmented)])] --- | Lookup 'Interval_Q' for given 'Interval_T' and semitone count.+-- | Lookup 'Interval_Quality' for given 'Interval_Type' and semitone count. -- -- > interval_q Unison 11 == Just Diminished -- > interval_q Third 5 == Just Augmented -- > interval_q Fourth 5 == Just Perfect -- > interval_q Unison 3 == Nothing-interval_q :: Interval_T -> Int -> Maybe Interval_Q+interval_q :: Interval_Type -> Int -> Maybe Interval_Quality interval_q i n = lookup i interval_q_tbl >>= lookup n --- | Lookup semitone difference of 'Interval_T' with 'Interval_Q'.+-- | Lookup semitone difference of 'Interval_Type' with 'Interval_Quality'. -- -- > interval_q_reverse Third Minor == Just 3 -- > interval_q_reverse Unison Diminished == Just 11-interval_q_reverse :: Interval_T -> Interval_Q -> Maybe Int+interval_q_reverse :: Interval_Type -> Interval_Quality -> Maybe Int interval_q_reverse ty qu =     case lookup ty interval_q_tbl of       Nothing -> Nothing@@ -98,8 +98,8 @@  -- | Determine 'Interval' between two 'Pitch'es. ----- > interval (Pitch C Sharp 4) (Pitch D Flat 4) == Interval Second Diminished EQ 0--- > interval (Pitch C Sharp 4) (Pitch E Sharp 5) == Interval Third Major LT 1+-- > interval (T.Pitch T.C T.Sharp 4) (T.Pitch T.D T.Flat 4) == Interval Second Diminished EQ 0+-- > interval (T.Pitch T.C T.Sharp 4) (T.Pitch T.E T.Sharp 5) == Interval Third Major LT 1 interval :: T.Pitch -> T.Pitch -> Interval interval p1 p2 =     let c = compare p1 p2@@ -109,7 +109,7 @@         p2' = T.pitch_to_pc p2         st = (p2' - p1') `mod` 12         ty = interval_ty n1 n2-        (Just qu) = interval_q ty (fromIntegral st)+        qu = fromMaybe (error "interval?") (interval_q ty (fromIntegral st))         o_a = if n1 > n2 then -1 else 0     in case c of          GT -> (interval p2 p1) { interval_direction = GT }@@ -121,14 +121,14 @@ invert_interval :: Interval -> Interval invert_interval (Interval t qu d o) = Interval t qu (T.ord_invert d) o --- | The signed difference in semitones between two 'Interval_Q'--- values when applied to the same 'Interval_T'.  Can this be written--- correctly without knowing the Interval_T?+-- | The signed difference in semitones between two 'Interval_Quality'+-- values when applied to the same 'Interval_Type'.  Can this be written+-- correctly without knowing the Interval_Type? -- -- > quality_difference_m Minor Augmented == Just 2 -- > quality_difference_m Augmented Diminished == Just (-3) -- > quality_difference_m Major Perfect == Nothing-quality_difference_m :: Interval_Q -> Interval_Q -> Maybe Int+quality_difference_m :: Interval_Quality -> Interval_Quality -> Maybe Int quality_difference_m a b =     let rule (x,y) =             if x == y@@ -152,7 +152,7 @@                       Nothing -> Nothing  -- | Erroring variant of 'quality_difference_m'.-quality_difference :: Interval_Q -> Interval_Q -> Int+quality_difference :: Interval_Quality -> Interval_Quality -> Int quality_difference a b =     let err = error ("quality_difference: " ++ show (a,b))     in fromMaybe err (quality_difference_m a b)@@ -203,7 +203,7 @@ -- displacement. -- -- > mapMaybe parse_interval_type (map show [1 .. 15])-parse_interval_type :: String -> Maybe (Interval_T,T.Octave)+parse_interval_type :: String -> Maybe (Interval_Type,T.Octave) parse_interval_type n =     case reads n of       [(n',[])] -> if n' == 0@@ -215,7 +215,7 @@ -- | Parse interval quality notation. -- -- > mapMaybe parse_interval_quality "dmPMA" == [minBound .. maxBound]-parse_interval_quality :: Char -> Maybe Interval_Q+parse_interval_quality :: Char -> Maybe Interval_Quality parse_interval_quality q =     let c = zip "dmPMA" [0..]     in fmap toEnum (lookup q c)@@ -224,11 +224,11 @@ -- 'parse_interval_type'. -- -- > map interval_type_degree [(Third,0),(Second,1),(Unison,2)] == [3,9,15]-interval_type_degree :: (Interval_T,T.Octave) -> Int+interval_type_degree :: (Interval_Type,T.Octave) -> Int interval_type_degree (t,o) = fromEnum t + 1 + (fromIntegral o * 7)  -- | Inverse of 'parse_interval_quality.-interval_quality_pp :: Interval_Q -> Char+interval_quality_pp :: Interval_Quality -> Char interval_quality_pp q = "dmPMA" !! fromEnum q  -- | Parse standard common music interval notation.
Music/Theory/Key.hs view
@@ -13,35 +13,35 @@ import qualified Music.Theory.Interval as T  -- | Enumeration of common music notation modes.-data Mode_T = Minor_Mode | Major_Mode+data Mode = Minor_Mode | Major_Mode               deriving (Eq,Ord,Show) --- | Pretty printer for 'Mode_T'.-mode_pp :: Mode_T -> String+-- | Pretty printer for 'Mode'.+mode_pp :: Mode -> String mode_pp m =     case m of       Minor_Mode -> "Minor"       Major_Mode -> "Major"  -- | Lower-cased 'mode_pp'.-mode_identifier_pp :: Mode_T -> String+mode_identifier_pp :: Mode -> String mode_identifier_pp = map toLower . mode_pp  -- | There are two modes, given one return the other.-mode_parallel :: Mode_T -> Mode_T+mode_parallel :: Mode -> Mode mode_parallel m = if m == Minor_Mode then Major_Mode else Minor_Mode -mode_pc_seq :: Num t => Mode_T -> [t]+mode_pc_seq :: Num t => Mode -> [t] mode_pc_seq md =     case md of       Major_Mode -> [0,2,4,5,7,9,11]       Minor_Mode -> [0,2,3,5,7,8,10] --- | A common music notation key is a 'Note_T', 'Alteration_T', 'Mode_T' triple.-type Key = (T.Note_T,T.Alteration_T,Mode_T)+-- | A common music notation key is a 'Note', 'Alteration', 'Mode' triple.+type Key = (T.Note,T.Alteration,Mode) --- | 'Mode_T' of 'Key'.-key_mode :: Key -> Mode_T+-- | 'Mode' of 'Key'.+key_mode :: Key -> Mode key_mode (_,_,m) = m  -- | Enumeration of 42 CMN keys.@@ -58,7 +58,7 @@ -- -- > length key_sequence_30 == 30 key_sequence_30 :: [Key]-key_sequence_30 = filter (\k -> maybe False ((< 8) . abs) (key_fifths k)) key_sequence_42+key_sequence_30 = filter (maybe False ((< 8) . abs) . key_fifths) key_sequence_42  -- | Parallel key, ie. 'mode_parallel' of 'Key'. key_parallel :: Key -> Key@@ -67,8 +67,8 @@ -- | Transposition of 'Key'. key_transpose :: Key -> Int -> Key key_transpose (n,a,m) x =-    let Just pc = T.note_alteration_to_pc (n,a)-        Just (n',a') = T.pc_to_note_alteration_ks ((pc + x) `mod` 12)+    let pc = fromMaybe (error "key_transpose?") (T.note_alteration_to_pc (n,a))+        (n',a') = fromMaybe (error "key_transpose?") (T.pc_to_note_alteration_ks ((pc + x) `mod` 12))     in (n',a',m)  -- | Relative key (ie. 'mode_parallel' with the same number of and type of alterations.@@ -98,7 +98,7 @@  -- | Pretty-printer where 'Minor_Mode' is written in lower case (lc) and -- alteration symbol is shown using indicated function.-key_lc_pp :: (T.Alteration_T -> String) -> Key -> String+key_lc_pp :: (T.Alteration -> String) -> Key -> String key_lc_pp a_pp (n,a,m) =     let c = T.note_pp n         c' = if m == Minor_Mode then toLower c else c@@ -121,7 +121,7 @@ key_lc_tonh_pp = key_lc_pp T.alteration_tonh  -- > map key_identifier_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)]-key_identifier_pp :: (Show a, Show a1) => (a, a1, Mode_T) -> [Char]+key_identifier_pp :: (Show a, Show a1) => (a, a1, Mode) -> [Char] key_identifier_pp (n,a,m) = map toLower (intercalate "_" [show n,show a,mode_pp m])  -- > import Data.Maybe@@ -133,17 +133,15 @@  -- | Parse 'Key' from /lc-uc/ string. ----- > import Data.Maybe--- -- > let k = mapMaybe key_lc_uc_parse ["c","E","f♯","ab","G#"]--- > in map key_lc_uc_pp k == ["c♮","E♮","f♯","a♭","G♯"]+-- > map key_lc_uc_pp k == ["c♮","E♮","f♯","a♭","G♯"] key_lc_uc_parse :: String -> Maybe Key key_lc_uc_parse k =     let with_k a (n,_,m) = (n,a,m)         with_a n a = fmap (with_k a) (note_char_to_key n)     in case k of          [c] -> note_char_to_key c-         [n,a] -> join (fmap (with_a n) (T.symbol_to_alteration_iso a))+         [n,a] -> with_a n =<< T.symbol_to_alteration_unicode_plus_iso a          _ -> Nothing  -- | Distance along circle of fifths path of indicated 'Key'.  A@@ -170,7 +168,7 @@ -- | Table mapping 'Key' to 'key_fifths' value. key_fifths_tbl :: [(Key,Int)] key_fifths_tbl =-    let f (k,n) = maybe Nothing (\n' -> Just (k,n')) n+    let f (k,n) = fmap (\n' -> (k,n')) n     in mapMaybe f (zip key_sequence_42 (map key_fifths key_sequence_42))  -- | Lookup 'key_fifths' value in 'key_fifths_tbl'.@@ -179,7 +177,7 @@ -- > let f md = map key_lc_iso_pp . mapMaybe (fifths_to_key md) -- > f Minor_Mode a -- > f Major_Mode a-fifths_to_key :: Mode_T -> Int -> Maybe Key+fifths_to_key :: Mode -> Int -> Maybe Key fifths_to_key md n =     let eq_f = (\((_,_,md'),n') -> md == md' && n == n')     in fmap fst (find eq_f key_fifths_tbl)@@ -188,18 +186,18 @@ -- -- > mapMaybe (implied_key Major_Mode) [[0,2,4],[1,3],[4,10],[3,9],[8,9]] -- > map (implied_key Major_Mode) [[0,1,2],[0,1,3,4]] == [Nothing,Nothing]-implied_key :: Integral i => Mode_T -> [i] -> Maybe Key+implied_key :: Integral i => Mode -> [i] -> Maybe Key implied_key md pc_set =     let a_seq = [0,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6]         key_seq = mapMaybe (fifths_to_key md) a_seq     in find (\k -> pc_set `T.is_subset` key_pc_set k) key_seq  -- | 'key_fifths' of 'implied_key'.-implied_fifths :: Integral i => Mode_T -> [i] -> Maybe Int-implied_fifths md = join . fmap key_fifths . implied_key md+implied_fifths :: Integral i => Mode -> [i] -> Maybe Int+implied_fifths md = key_fifths <=< implied_key md -implied_key_err :: Integral i => Mode_T -> [i] -> Key+implied_key_err :: Integral i => Mode -> [i] -> Key implied_key_err md = fromMaybe (error "implied_key") . implied_key md -implied_fifths_err :: Integral i => Mode_T -> [i] -> Int+implied_fifths_err :: Integral i => Mode -> [i] -> Int implied_fifths_err md = fromMaybe (error "implied_fifths") . key_fifths . implied_key_err md
− Music/Theory/List.hs 
@@ -1,1475 +0,0 @@--- | List functions.-module Music.Theory.List where--import Data.Either {- base -}-import Data.Function {- base -}-import Data.List {- base -}-import Data.Maybe {- 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.Tree as Tree {- containers -}--import qualified Control.Monad.Logic as L {- logict -}---- | 'Data.Vector.slice', ie. starting index (zero-indexed) and number of elements.------ > slice 4 5 [1..] == [5,6,7,8,9]-slice :: Int -> Int -> [a] -> [a]-slice i n = take n . drop i---- | Variant of slice with start and end indices (zero-indexed).------ > section 4 8 [1..] == [5,6,7,8,9]-section :: Int -> Int -> [a] -> [a]-section l r = take (r - l + 1) . drop l---- | Bracket sequence with left and right values.------ > bracket ('<','>') "1,2,3" == "<1,2,3>"-bracket :: (a,a) -> [a] -> [a]-bracket (l,r) x = l : x ++ [r]---- | 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.------ > map unbracket ["","{12}"] == [Nothing,Just ('{',"12",'}')]-unbracket :: [t] -> Maybe (t,[t],t)-unbracket x =-    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---- * Split---- | Relative of 'splitOn', but only makes first separation.------ > splitOn "//" "lhs//rhs//rem" == ["lhs","rhs","rem"]--- > separate_at "//" "lhs//rhs//rem" == Just ("lhs","rhs//rem")-separate_at :: Eq a => [a] -> [a] -> Maybe ([a],[a])-separate_at x =-    let n = length x-        f lhs rhs =-            if null rhs-            then Nothing-            else if x == take n rhs-                 then Just (reverse lhs,drop n rhs)-                 else f (head rhs : lhs) (tail rhs)-    in f []---- | 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, 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_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'.------ > 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'.-genericRotate_left :: Integral i => i -> [a] -> [a]-genericRotate_left n =-    let f (p,q) = q ++ p-    in f . genericSplitAt n---- | Left rotation.------ > rotate_left 1 [1..3] == [2,3,1]--- > rotate_left 3 [1..5] == [4,5,1,2,3]-rotate_left :: Int -> [a] -> [a]-rotate_left = genericRotate_left---- | Generic form of 'rotate_right'.-genericRotate_right :: Integral n => n -> [a] -> [a]-genericRotate_right n = reverse . genericRotate_left n . reverse---- | Right rotation.------ > rotate_right 1 [1..3] == [3,1,2]-rotate_right :: Int -> [a] -> [a]-rotate_right = genericRotate_right---- | Rotate left by /n/ 'mod' /#p/ places.------ > rotate 1 [1..3] == [2,3,1]--- > rotate 8 [1..5] == [4,5,1,2,3]-rotate :: (Integral n) => n -> [a] -> [a]-rotate n p =-    let m = n `mod` genericLength p-    in genericRotate_left m p---- | Rotate right by /n/ places.------ > rotate_r 8 [1..5] == [3,4,5,1,2]-rotate_r :: (Integral n) => n -> [a] -> [a]-rotate_r = rotate . negate---- | All rotations.------ > rotations [0,1,3] == [[0,1,3],[1,3,0],[3,0,1]]-rotations :: [a] -> [[a]]-rotations p = map (`rotate_left` p) [0 .. length p - 1]---- | Rotate list so that is starts at indicated element.------ > rotate_starting_from 'c' "abcde" == Just "cdeab"--- > rotate_starting_from '_' "abc" == Nothing-rotate_starting_from :: Eq a => a -> [a] -> Maybe [a]-rotate_starting_from x l =-    case break (== x) l of-      (_,[]) -> Nothing-      (lhs,rhs) -> Just (rhs ++ lhs)---- | Erroring variant.-rotate_starting_from_err :: Eq a => a -> [a] -> [a]-rotate_starting_from_err x =-    fromMaybe (error "rotate_starting_from: non-element") .-    rotate_starting_from x---- | Sequence of /n/ adjacent elements, moving forward by /k/ places.--- The last element may have fewer than /n/ places, but will reach the--- end of the input sequence.------ > adj 3 2 "adjacent" == ["adj","jac","cen","nt"]-adj :: Int -> Int -> [a] -> [[a]]-adj n k l =-    case take n l of-      [] -> []-      r -> r : adj n k (drop k l)---- | Variant of 'adj' where the last element has /n/ places but may--- not reach the end of the input sequence.------ > adj_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_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 =-    case l of-      p:q:_ -> (p,q) : genericAdj2 n (genericDrop n l)-      _ -> []---- | Adjacent elements of list, at indicated distance, as pairs.------ > adj2 1 [1..5] == [(1,2),(2,3),(3,4),(4,5)]--- > let l = [1..5] in zip l (tail l) == adj2 1 l--- > adj2 2 [1..4] == [(1,2),(3,4)]--- > adj2 3 [1..5] == [(1,2),(4,5)]-adj2 :: Int -> [t] -> [(t,t)]-adj2 = genericAdj2---- | Append first /n/-elements to end of list.------ > close 1 [1..3] == [1,2,3,1]-close :: Int -> [a] -> [a]-close k x = x ++ take k x---- | '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 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]--- > interleave ".+-" "abc" == ".a+b-c"--- > interleave [1..3] [] == []-interleave :: [a] -> [a] -> [a]-interleave p q =-    let u (i,j) = [i,j]-    in concatMap u (zip p q)---- | Interleave list of lists.  Allows lists to be of non-equal lenghts.------ > interleave_set ["abcd","efgh","ijkl"] == "aeibfjcgkdhl"--- > interleave_set ["abc","defg","hijkl"] == "adhbeicfjgkl"-interleave_set :: [[a]] -> [a]-interleave_set = concat . transpose--{--import Safe {- safe -}--interleave_set l =-    case mapMaybe headMay l of-      [] -> []-      r -> r ++ interleave_set (mapMaybe tailMay l)--}---- | De-interleave /n/ lists.------ > deinterleave 2 ".a+b-c" == [".+-","abc"]--- > deinterleave 3 "aeibfjcgkdhl" == ["abcd","efgh","ijkl"]-deinterleave :: Int -> [a] -> [[a]]-deinterleave n = transpose . S.chunksOf n---- | Special case for two-part deinterleaving.------ > deinterleave2 ".a+b-c" == (".+-","abc")-deinterleave2 :: [t] -> ([t], [t])-deinterleave2 =-    let f l =-            case l of-              p:q:l' -> (p,q) : f l'-              _ -> []-    in unzip . f--{--deinterleave2 =-    let f p q l =-            case l of-              [] -> (reverse p,reverse q)-              [a] -> (reverse (a:p),reverse q)-              a:b:l' -> rec (a:p) (b:q) l'-    in f [] []--}---- | Variant that continues with the longer input.------ > interleave_continue ".+-" "abc" == ".a+b-c"--- > interleave_continue [1..3] [] == [1..3]--- > interleave_continue [] [1..3] == [1..3]-interleave_continue :: [a] -> [a] -> [a]-interleave_continue p q =-    case (p,q) of-      ([],_) -> q-      (_,[]) -> p-      (i:p',j:q') -> i : j : interleave_continue p' q'---- | 'interleave' of 'rotate_left' by /i/ and /j/.------ > interleave_rotations 9 3 [1..13] == [10,4,11,5,12,6,13,7,1,8,2,9,3,10,4,11,5,12,6,13,7,1,8,2,9,3]-interleave_rotations :: Int -> Int -> [b] -> [b]-interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s)---- | '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)---- | 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, '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","yxx"] == [[],[('h',3),('o',2)],[('x',2),('y',1)]]-histogram :: Ord a => [a] -> [(a,Int)]-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 (Just compare)---- | 'duplicates_by' of '=='.------ > map duplicates ["duplicates","redundant"] == ["","dn"]-duplicates :: Ord a => [a] -> [a]-duplicates = duplicates_by (==)---- | List segments of length /i/ at distance /j/.------ > segments 2 1 [1..5] == [[1,2],[2,3],[3,4],[4,5]]--- > segments 2 2 [1..5] == [[1,2],[3,4]]-segments :: Int -> Int -> [a] -> [[a]]-segments i j p =-    let q = take i p-        p' = drop j p-    in if length q /= i then [] else q : segments i j p'---- | 'foldl1' 'intersect'.------ > intersect_l [[1,2],[1,2,3],[1,2,3,4]] == [1,2]-intersect_l :: Eq a => [[a]] -> [a]-intersect_l = foldl1 intersect---- | 'foldl1' 'union'.------ > sort (union_l [[1,3],[2,3],[3]]) == [1,2,3]-union_l :: Eq a => [[a]] -> [a]-union_l = foldl1 union---- | Intersection of adjacent elements of list at distance /n/.------ > adj_intersect 1 [[1,2],[1,2,3],[1,2,3,4]] == [[1,2],[1,2,3]]-adj_intersect :: Eq a => Int -> [[a]] -> [[a]]-adj_intersect n = map intersect_l . segments 2 n---- | List of cycles at distance /n/.------ > cycles 2 [1..6] == [[1,3,5],[2,4,6]]--- > cycles 3 [1..9] == [[1,4,7],[2,5,8],[3,6,9]]--- > cycles 4 [1..8] == [[1,5],[2,6],[3,7],[4,8]]-cycles :: Int -> [a] -> [[a]]-cycles n = transpose . S.chunksOf n---- | Variant of 'filter' that has a predicate to halt processing,--- ie. 'filter' of 'takeWhile'.------ > filter_halt (even . fst) ((< 5) . snd) (zip [1..] [0..])-filter_halt :: (a -> Bool) -> (a -> Bool) -> [a] -> [a]-filter_halt sel end = filter sel . takeWhile end---- | 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"--- > replace "ab" "cd" "ab ab cd ab" == "cd cd cd cd"-replace :: Eq a => [a] -> [a] -> [a] -> [a]-replace p q s =-    let n = length p-    in case s of-         [] -> []-         c:s' -> if p `isPrefixOf` s-                 then q ++ replace p q (drop n s)-                 else c : replace p q s'---- | Replace the /i/th value at /ns/ with /x/.------ > replace_at "test" 2 'n' == "tent"-replace_at :: Integral i => [a] -> i -> a -> [a]-replace_at ns i x =-    let f j y = if i == j then x else y-    in zipWith f [0..] ns---- * Association lists---- | Equivalent to 'groupBy' /eq/ 'on' /f/.------ > 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 = group_by_on (==)---- | 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_by_on_adjacent"-                l0:_ -> (f l0,map g l)-    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 :: Eq a => [(a,b)] -> [(a,[b])]-collate_adjacent = collate_on_adjacent fst snd---- | 'sortOn' prior to 'collate_on_adjacent'.------ > 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---- | 'collate_on' of 'fst' and 'snd'.------ > collate (zip "TDD" "xyz") == [('D',"yz"),('T',"x")]--- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")]-collate :: Ord a => [(a,b)] -> [(a,[b])]-collate = collate_on fst snd---- | Reverse of 'collate', inverse if order is not considered.------ > uncollate [(1,"ac"),(2,"b")] == zip [1,1,2] "acb"-uncollate :: [(k,[v])] -> [(k,v)]-uncollate = concatMap (\(k,v) -> zip (repeat k) v)---- | Make /assoc/ list with given /key/.------ > with_key 'a' [1..3] == [('a',1),('a',2),('a',3)]-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]-dx_d :: (Num a) => a -> [a] -> [a]-dx_d = scanl (+)---- | Variant that takes initial value and separates final value.  This--- is an appropriate function for 'mapAccumL'.------ > dx_d' 5 [1,2,3] == (11,[5,6,8])--- > dx_d' 0 [1,1,1] == (3,[0,1,2])-dx_d' :: Num t => t -> [t] -> (t,[t])-dx_d' n l =-    case reverse (scanl (+) n l) of-      e:r -> (e,reverse r)-      _ -> error "dx_d'"---- | 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---- | Integrate, 'd_dx_by' '-', ie. pitch class segment to interval sequence.------ > d_dx [5,6,8,11] == [1,2,3]--- > d_dx [] == []-d_dx :: (Num a) => [a] -> [a]-d_dx = d_dx_by (-)---- | Elements of /p/ not in /q/.------ > [1,2,3] `difference` [1,2] == [3]-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/.------ > is_subset [1,2] [1,2,3] == True-is_subset :: Eq a => [a] -> [a] -> Bool-is_subset p q = p `intersect` q == p---- | Is /p/ a superset of /q/, ie. 'flip' 'is_subset'.------ > is_superset [1,2,3] [1,2] == True-is_superset :: Eq a => [a] -> [a] -> Bool-is_superset = flip is_subset---- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'.------ > subsequence [1,2] [1,2,3] == True-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 e p =-    case elemIndices e p of-      [i] -> i-      _ -> error "elem_index_unique"---- | 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---- | Error variant.-lookup_err :: Eq k => k -> [(k,v)] -> v-lookup_err n = fromMaybe (error "lookup") . lookup n---- | 'lookup' variant with default value.-lookup_def :: Eq k => k -> v -> [(k,v)] -> v-lookup_def k d = fromMaybe d . lookup k---- | 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 '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 =-    case ls of-      [] -> Nothing-      (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 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_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_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_cmp f l' x--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, 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 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) => 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_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.------ > let {f = find_bounds True compare [1..5]--- >     ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]}--- > in map f [0,1,3.5,5] == r-find_bounds :: Bool -> (t -> s -> Ordering) -> [t] -> s -> Maybe (t,t)-find_bounds scl f l = find_bounds_scl scl f (adj2 1 l)---- | Special case of 'dropRight'.------ > map drop_last ["","?","remove"] == ["","","remov"]-drop_last :: [t] -> [t]-drop_last l =-    case l of-      [] -> []-      [_] -> []-      e:l' -> e : drop_last l'---- | Variant of 'drop' from right of list.------ > dropRight 1 [1..9] == [1..8]-dropRight :: Int -> [a] -> [a]-dropRight n = reverse . drop n . reverse---- | Variant of 'dropWhile' from right of list.------ > dropWhileRight Data.Char.isDigit "A440" == "A"-dropWhileRight :: (a -> Bool) -> [a] -> [a]-dropWhileRight p = reverse . dropWhile p . reverse---- | 'take' from right.------ > take_right 3 "taking" == "ing"-take_right :: Int -> [a] -> [a]-take_right n = reverse . take n . reverse---- | 'takeWhile' from right.------ > take_while_right Data.Char.isDigit "A440" == "440"-take_while_right :: (a -> Bool) -> [a] -> [a]-take_while_right p = reverse . takeWhile p . reverse---- | 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]-at_head :: (a -> b) -> (a -> b) -> [a] -> [b]-at_head f g x =-    case x of-      [] -> []-      e:x' -> f e : map g x'---- | Apply /f/ at all but last element, and /g/ at last element.------ > at_last (* 2) negate [1..4] == [2,4,6,-4]-at_last :: (a -> b) -> (a -> b) -> [a] -> [b]-at_last f g x =-    case x of-      [] -> []-      [i] -> [g i]-      i:x' -> f i : at_last f g x'---- | Separate list into an initial list and perhaps the last element tuple.------ > separate_last' [] == ([],Nothing)-separate_last' :: [a] -> ([a],Maybe a)-separate_last' x =-    case reverse x of-      [] -> ([],Nothing)-      e:x' -> (reverse x',Just e)---- | Error on null input.------ > separate_last [1..5] == ([1..4],5)-separate_last :: [a] -> ([a],a)-separate_last = fmap (fromMaybe (error "separate_last")) . separate_last'---- | Replace directly repeated elements with 'Nothing'.------ > indicate_repetitions "abba" == [Just 'a',Just 'b',Nothing,Just 'a']-indicate_repetitions :: Eq a => [a] -> [Maybe a]-indicate_repetitions =-    let f l = case l of-                [] -> []-                e:l' -> Just e : map (const Nothing) l'-    in concatMap f . group---- | 'zipWith' of list and it's own tail.------ > zip_with_adj (,) "abcde" == [('a','b'),('b','c'),('c','d'),('d','e')]-zip_with_adj :: (a -> a -> b) -> [a] -> [b]-zip_with_adj f xs = zipWith f xs (tail xs)---- | Type-specialised 'zip_with_adj'.-compare_adjacent_by :: (a -> a -> Ordering) -> [a] -> [Ordering]-compare_adjacent_by = zip_with_adj---- | 'compare_adjacent_by' of 'compare'.------ > compare_adjacent [0,1,3,2] == [LT,LT,GT]-compare_adjacent :: Ord a => [a] -> [Ordering]-compare_adjacent = compare_adjacent_by compare---- | 'Data.List.groupBy' does not make adjacent comparisons, it--- compares each new element to the start of the group.  This function--- is the adjacent variant.------ > groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3,2,4],[1,5,9]]--- > adjacent_groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3],[2,4],[1,5,9]]-adjacent_groupBy :: (a -> a -> Bool) -> [a] -> [[a]]-adjacent_groupBy f p =-    case p of-      [] -> []-      [x] -> [[x]]-      x:y:p' -> let r = adjacent_groupBy f (y:p')-                    r0:r' = r-                in if f x y-                   then (x:r0) : r'-                   else [x] : r---- | Reduce sequences of consecutive values to ranges.------ > group_ranges [-1,0,3,4,5,8,9,12] == [(-1,0),(3,5),(8,9),(12,12)]--- > group_ranges [3,2,3,4,3] == [(3,3),(2,4),(3,3)]-group_ranges :: (Num t, Eq t) => [t] -> [(t,t)]-group_ranges =-    let f l = (head l,last l)-    in map f . adjacent_groupBy (\p q -> p + 1 == q)---- | 'groupBy' on /structure/ of 'Maybe', ie. all 'Just' compare equal.------ > let r = [[Just 1],[Nothing,Nothing],[Just 4,Just 5]]--- > in group_just [Just 1,Nothing,Nothing,Just 4,Just 5] == r-group_just :: [Maybe a] -> [[Maybe a]]-group_just = group_on isJust---- | Predicate to determine if all elements of the list are '=='.------ > all_equal "aaa" == True-all_equal :: Eq a => [a] -> Bool-all_equal l =-    case l of-      [] -> True-      [_] -> True-      x:xs -> all id (map (== x) xs)---- | Variant using 'nub'.-all_eq :: Eq n => [n] -> Bool-all_eq = (== 1) . length . nub---- | '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')]]--- > in sort_group_on fst (zip "13123" "abcde") == r-sort_group_on :: Ord b => (a -> b) -> [a] -> [[a]]-sort_group_on f = group_on f . sortOn f---- | Maybe cons element onto list.------ > Nothing `mcons` "something" == "something"--- > Just 's' `mcons` "omething" == "something"-mcons :: Maybe a -> [a] -> [a]-mcons e l = maybe l (:l) e---- | 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.-type Compare_F a = a -> a -> Ordering---- | If /f/ compares 'EQ', defer to /g/.-two_stage_compare :: Compare_F a -> Compare_F a -> Compare_F a-two_stage_compare f g p q =-    case f p q of-      EQ -> g p q-      r -> r---- | '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--- > n_stage_compare [compare `on` snd,compare `on` fst] (1,0) (0,1) == LT-n_stage_compare :: [Compare_F a] -> Compare_F a-n_stage_compare l p q =-    case l of-      [] -> EQ-      f:l' -> case f p q of-                EQ -> n_stage_compare l' p q-                r -> r---- | '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"--- > sort_to "adbce" [1,4,2,3,5] == "abcde"-sort_to :: Ord i => [e] -> [i] -> [e]-sort_to e = map fst . sortOn snd . zip e---- | 'flip' of '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 :: 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 :: [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]-merge_by :: Compare_F a -> [a] -> [a] -> [a]-merge_by = O.mergeBy---- | 'merge_by' 'compare' 'on'.-merge_on :: Ord x => (a -> x) -> [a] -> [a] -> [a]-merge_on f = merge_by (compare `on` f)---- | 'O.mergeBy' of 'two_stage_compare'.-merge_by_two_stage :: Ord b => (a -> b) -> Compare_F c -> (a -> c) -> [a] -> [a] -> [a]-merge_by_two_stage f cmp g = O.mergeBy (two_stage_compare (compare `on` f) (cmp `on` g))---- | 'mergeBy' 'compare'.-merge :: Ord a => [a] -> [a] -> [a]-merge = O.merge---- | Merge list of sorted lists given comparison function.  Note that--- this is not equal to 'O.mergeAll'.-merge_set_by :: (a -> a -> Ordering) -> [[a]] -> [a]-merge_set_by f = foldr (merge_by f) []---- | 'merge_set_by' of 'compare'.------ > merge_set [[1,3,5,7,9],[2,4,6,8],[10]] == [1..10]-merge_set :: Ord a => [[a]] -> [a]-merge_set = merge_set_by compare--{-| 'merge_by' variant that joins (resolves) equal elements.--> let {left p _ = p->     ;right _ q = q->     ;cmp = compare `on` fst->     ;p = zip [1,3,5] "abc"->     ;q = zip [1,2,3] "ABC"->     ;left_r = [(1,'a'),(2,'B'),(3,'b'),(5,'c')]->     ;right_r = [(1,'A'),(2,'B'),(3,'C'),(5,'c')]}-> in merge_by_resolve left cmp p q == left_r &&->    merge_by_resolve right cmp p q == right_r--> merge_by_resolve (\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 =-    let recur p q =-            case (p,q) of-              ([],_) -> q-              (_,[]) -> p-              (l:p',r:q') -> case cmp l r of-                               LT -> l : recur p' q-                               EQ -> jn l r : recur p' q'-                               GT -> r : recur p q'-    in recur---- | 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 f p q then Just (p,q) else find_adj f (q:xs')-      _ -> Nothing---- | '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 = 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'.------ > 16 `elem_ordered` [1,3 ..] == False--- > 16 `elem` [1,3 ..] == undefined-elem_ordered :: Ord t => t -> [t] -> Bool-elem_ordered = O.member---- | Variant of `elemIndex` that operates on a sorted list, halting.------ > 16 `elemIndex_ordered` [1,3 ..] == Nothing--- > 16 `elemIndex_ordered` [0,1,4,9,16,25,36,49,64,81,100] == Just 4-elemIndex_ordered :: Ord t => t -> [t] -> Maybe Int-elemIndex_ordered e =-    let recur k l =-            case l of-              [] -> Nothing-              x:l' -> if e == x-                      then Just k-                      else if x > e-                           then Nothing-                           else recur (k + 1) l'-    in recur 0---- | '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")-zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])-zip_with_kr f =-    let go r p q =-            case (p,q) of-              (i:p',j:q') -> go (f i j : r) p' q'-              _ -> (reverse r,q)-    in go []---- | A 'zipWith' variant that always consumes an element from the left--- hand side (lhs), but only consumes an element from the right hand--- side (rhs) if the zip function is 'Right' and not if 'Left'.--- There's also a secondary function to continue if the rhs ends--- before the lhs.-zip_with_perhaps_rhs :: (a -> b -> Either c c) -> (a -> c) -> [a] -> [b] -> [c]-zip_with_perhaps_rhs f g lhs rhs =-    case (lhs,rhs) of-      ([],_) -> []-      (_,[]) -> map g lhs-      (p:lhs',q:rhs') -> case f p q of-                           Left r -> r : zip_with_perhaps_rhs f g lhs' rhs-                           Right r -> r : zip_with_perhaps_rhs f g lhs' rhs'---- | Fill gaps in a sorted association list, range is inclusive at both ends.------ > let r = [(1,'a'),(2,'x'),(3,'x'),(4,'x'),(5,'b'),(6,'x'),(7,'c'),(8,'x'),(9,'x')]--- > in fill_gaps_ascending' 'x' (1,9) (zip [1,5,7] "abc") == r-fill_gaps_ascending :: (Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]-fill_gaps_ascending def_e (l,r) =-    let f i (j,e) = if j > i then Left (i,def_e) else Right (j,e)-        g i = (i,def_e)-    in zip_with_perhaps_rhs f g [l .. r]---- | Direct definition.-fill_gaps_ascending' :: (Num n,Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]-fill_gaps_ascending' def (l,r) =-    let recur n x =-            if n > r-            then []-            else case x of-                   [] -> zip [n .. r] (repeat def)-                   (m,e):x' -> if n < m-                               then (n,def) : recur (n + 1) x-                               else (m,e) : recur (n + 1) x'-    in recur l---- | 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 "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---- | 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']-pad_left :: a -> Int -> [a] -> [a]-pad_left k n l = replicate (n - length l) k ++ l---- * Embedding---- | Locate first (leftmost) embedding of /q/ in /p/.--- Return partial indices for failure at 'Left'.------ > embedding ("embedding","ming") == Right [1,6,7,8]--- > embedding ("embedding","mind") == Left [1,6,7]-embedding :: Eq t => ([t],[t]) -> Either [Int] [Int]-embedding =-    let recur n r (p,q) =-            case (p,q) of-              (_,[]) -> Right (reverse r)-              ([],_) -> Left (reverse r)-              (x:p',y:q') ->-                  let n' = n + 1-                      r' = if x == y then n : r else r-                  in recur n' r' (p',if x == y then q' else q)-    in recur 0 []--embedding_err :: Eq t => ([t],[t]) -> [Int]-embedding_err = either (error "embedding_err") id . embedding---- | Does /q/ occur in sequence, though not necessarily adjacently, in /p/.------ > is_embedding [1 .. 9] [1,3,7] == True--- > is_embedding "embedding" "ming" == True--- > is_embedding "embedding" "mind" == False-is_embedding :: Eq t => [t] -> [t] -> Bool-is_embedding p q = isRight (embedding (p,q))--all_embeddings_m :: (Eq t,L.MonadLogic m) => [t] -> [t] -> m [Int]-all_embeddings_m p q =-    let q_n = length q-        recur p' q' n k = -- n = length k-            if n == q_n-            then return (reverse k)-            else do (m,c) <- L.msum (map return p')-                    let k0:_ = k-                        c':_ = q'-                    L.guard (c == c' && (null k || m > k0))-                    let _:p'' = p'-                        _:q'' = q'-                    recur p'' q'' (n + 1) (m : k)-    in recur (zip [0..] p) q 0 []---- | Enumerate indices for all embeddings of /q/ in /p/.------ > all_embeddings "all_embeddings" "leg" == [[1,4,12],[1,7,12],[2,4,12],[2,7,12]]-all_embeddings :: Eq t => [t] -> [t] -> [[Int]]-all_embeddings p = L.observeAll . all_embeddings_m p---- * Un-list---- | Unpack one element list.-unlist1 :: [t] -> Maybe t-unlist1 l =-    case l of-      [e] -> Just e-      _ -> Nothing---- | Erroring variant.-unlist1_err :: [t] -> t-unlist1_err = fromMaybe (error "unlist1") . unlist1---- * Traversable---- | Replace elements at 'Traversable' with result of joining with elements from list.------ > let t = Node 0 [Node 1 [Node 2 [],Node 3 []],Node 4 []]--- > putStrLn $ drawTree (fmap show t)--- > let (_,u) = adopt_shape (\_ x -> x) "abcde" t--- > putStrLn $ drawTree (fmap return u)-adopt_shape :: 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 mapAccumL f l---- | Two-level variant of 'adopt_shape'.------ > 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 mapAccumL f l---- * Tree--{- | Given an 'Ordering' predicate where 'LT' opens a group, 'GT'-closes a group, and 'EQ' continues current group, construct tree-from list.--> let l = "a {b {c d} e f} g h i"-> 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.Tree (Maybe a)-group_tree (open_f,close_f) =-    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')-              [] -> (unit e : r,[])-        do_open (r,z) = (r,nil:z)-        do_close (r,z) =-            case z of-              h0:h1:z' -> (r,insert_e h1 (reverse_n h0) : z')-              h:z' -> (reverse_n h : r,z')-              [] -> (r,z)-        go st x =-            case x of-              [] -> 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-                           then go (do_close (do_push st e)) x'-                           else go (do_push st e) x'-    in go ([],[])---- * Indexing---- | Remove element at index.------ > remove_ix 5 "remove" == "remov"--- > remove_ix 5 "short" == undefined-remove_ix :: Int -> [a] -> [a]-remove_ix k l = let (p,q) = splitAt k l in p ++ tail q---- | 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---- | Replace element at /i/ in /p/ by application of /f/.------ > replace_ix negate 1 [1..3] == [1,-2,3]-replace_ix :: (a -> a) -> Int -> [a] -> [a]-replace_ix f i p =-    let (q,r:s) = splitAt i p-    in q ++ (f r : s)---- | 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.------ > map (at_cyclic "cycle") [0..9] == "cyclecycle"-at_cyclic :: [a] -> Int -> a-at_cyclic l n =-    let m = Map.fromList (zip [0..] l)-        k = Map.size m-        n' = n `mod` k-    in fromMaybe (error "cyc_at") (Map.lookup n' m)-
+ Music/Theory/List/Logic.hs view
@@ -0,0 +1,29 @@+-- | List/Logic functions.+module Music.Theory.List.Logic where++import Control.Monad {- base -}++import qualified Control.Monad.Logic as L {- logict -}++-- | 'L.MonadLogic' value to enumerate indices for all embeddings of /q/ in /p/.+all_embeddings_m :: (Eq t, MonadPlus m, L.MonadLogic m) => [t] -> [t] -> m [Int]+all_embeddings_m p q =+    let q_n = length q+        recur p' q' n k = -- n = length k+            if n == q_n+            then return (reverse k)+            else do (m,c) <- msum (map return p')+                    let k0 = head k+                        c' = head q'+                    guard (c == c' && (null k || m > k0))+                    let p'' = tail p'+                        q'' = tail q'+                    recur p'' q'' (n + 1) (m : k)+    in recur (zip [0..] p) q 0 []++-- | 'L.observeAll' of 'all_embeddings_m'+--+-- > all_embeddings "all_embeddings" "leg" == [[1,4,12],[1,7,12],[2,4,12],[2,7,12]]+all_embeddings :: Eq t => [t] -> [t] -> [[Int]]+all_embeddings p = L.observeAll . all_embeddings_m p+
− Music/Theory/Map.hs 
@@ -1,17 +0,0 @@--- | Map functions.-module Music.Theory.Map where--import qualified Data.Map as M {- containers -}-import Data.Maybe {- base -}---- | Erroring 'M.lookup'.-map_lookup_err :: Ord k => k -> M.Map k c -> c-map_lookup_err k = fromMaybe (error "M.lookup") . M.lookup k---- | 'flip' of 'M.lookup'.-map_ix :: Ord k => M.Map k c -> k -> Maybe c-map_ix = flip M.lookup---- | 'flip' of 'map_lookup_err'.-map_ix_err :: Ord k => M.Map k c -> k -> c-map_ix_err = flip map_lookup_err
− Music/Theory/Math.hs 
@@ -1,280 +0,0 @@--- | Math functions.-module Music.Theory.Math where--import Data.List {- base -}-import Data.Maybe {- base -}-import Data.Ratio {- base -}--import qualified Music.Theory.Math.Convert as T---- | 'mod' 5.-mod5 :: Integral i => i -> i-mod5 n = n `mod` 5---- | 'mod' 7.-mod7 :: Integral i => i -> i-mod7 n = n `mod` 7---- | 'mod' 12.-mod12 :: Integral i => i -> i-mod12 n = n `mod` 12---- | 'mod' 16.-mod16 :: Integral i => i -> i-mod16 n = n `mod` 16---- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html>------ > integral_and_fractional_parts 1.5 == (1,0.5)-integral_and_fractional_parts :: (Integral i, RealFrac t) => t -> (i,t)-integral_and_fractional_parts n =-    if n >= 0-    then let n' = floor n in (n',n - fromIntegral n')-    else let n' = ceiling n in (n',n - fromIntegral n')---- | Type specialised.-integer_and_fractional_parts :: RealFrac t => t -> (Integer,t)-integer_and_fractional_parts = integral_and_fractional_parts---- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html>------ > import Sound.SC3.Plot {- hsc3-plot -}--- > 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---- | 'floor' of 'T.real_to_double'.-real_floor :: (Real r,Integral i)  => r -> i-real_floor = floor . T.real_to_double---- | Type specialised 'real_floor'.-real_floor_int :: Real r => r -> Int-real_floor_int = real_floor---- | 'round' of 'T.real_to_double'.-real_round :: (Real r,Integral i)  => r -> i-real_round = round . T.real_to_double---- | Type specialised 'real_round'.-real_round_int :: Real r => r -> Int-real_round_int = real_round---- | 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]--- > 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---- | Is /r/ whole to /k/ decimal places.------ > map (flip whole_to_precision 1.00009) [4,5] == [True,False]-whole_to_precision :: Real r => Int -> r -> Bool-whole_to_precision k = zero_to_precision k . fractional_part . T.real_to_double---- | <http://reference.wolfram.com/mathematica/ref/SawtoothWave.html>------ > 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---- | Predicate that is true if @n/d@ can be simplified, ie. where--- 'gcd' of @n@ and @d@ is not @1@.------ > 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---- | 'numerator' and 'denominator' of rational.-rational_nd :: Ratio t -> (t,t)-rational_nd r = (numerator r,denominator r)---- | Rational as a whole number, or 'Nothing'.-rational_whole :: Integral a => Ratio a -> Maybe a-rational_whole r = if denominator r == 1 then Just (numerator r) else Nothing---- | Erroring variant.-rational_whole_err :: Integral a => Ratio a -> a-rational_whole_err = fromMaybe (error "rational_whole") . rational_whole---- | Sum of numerator & denominator.-ratio_nd_sum :: Num a => Ratio a -> a-ratio_nd_sum r = numerator r + denominator r---- | Is /n/ a whole (integral) value.------ > 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-floor_f = fromInteger . floor---- | Round /b/ to nearest multiple of /a/.------ > map (round_to 0.25) [0,0.1 .. 1] == [0.0,0.0,0.25,0.25,0.5,0.5,0.5,0.75,0.75,1.0,1.0]--- > map (round_to 25) [0,10 .. 100] == [0,0,25,25,50,50,50,75,75,100,100]-round_to :: RealFrac n => n -> n -> n-round_to a b = if a == 0 then b else floor_f ((b / a) + 0.5) * a---- | 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.------ > map (`oi_mod` 5) [1..10] == [1,2,3,4,5,1,2,3,4,5]-oi_mod :: Integral a => a -> a -> a-oi_mod n m = ((n - 1) `mod` m) + 1---- | One-indexed 'divMod' function.------ > map (`oi_divMod` 5) [1,3 .. 9] == [(0,1),(0,3),(0,5),(1,2),(1,4)]-oi_divMod :: Integral t => t -> t -> (t, t)-oi_divMod n m = let (i,j) = (n - 1) `divMod` m in (i,j + 1)---- * I = integral---- | Integral square root function.------ > map i_square_root [0,1,4,9,16,25,36,49,64,81,100] == [0 .. 10]--- > map i_square_root [4 .. 16] == [2,2,2,2,2,3,3,3,3,3,3,3,4]-i_square_root :: Integral t => t -> t-i_square_root n =-    let babylon a =-            let b  = quot (a + quot n a) 2-            in if a > b then babylon b else a-    in case compare n 0 of-         GT -> babylon n-         EQ -> 0-         _ -> error "i_square_root: negative?"---- * Interval---- | (0,1) = {x | 0 < x < 1}-in_open_interval :: Ord a => (a, a) -> a -> Bool-in_open_interval (p,q) n = p < n && n < q---- | [0,1] = {x | 0 ≤ x ≤ 1}-in_closed_interval :: Ord a => (a, a) -> a -> Bool-in_closed_interval (p,q) n = p <= n && n <= q---- | (p,q] (0,1] = {x | 0 < x ≤ 1}-in_left_half_open_interval :: Ord a => (a, a) -> a -> Bool-in_left_half_open_interval (p,q) n = p < n && n <= q---- | [p,q) [0,1) = {x | 0 ≤ x < 1}-in_right_half_open_interval :: Ord a => (a, a) -> a -> Bool-in_right_half_open_interval (p,q) n = p <= n && n < q---- | Calculate /n/th root of /x/.------ > 12 `nth_root` 2 == 1.0594630943592953-nth_root :: (Floating a,Eq a) => a -> a -> a-nth_root n x =-    let f (_,x0) = (x0, ((n - 1) * x0 + x / x0 ** (n - 1)) / n)-        eq = uncurry (==)-    in fst (until eq f (x, x/n))---- | Arithmetic mean (average) of a list.------ > map arithmetic_mean [[-3..3],[0..5],[1..5],[3,5,7],[7,7],[3,9,10,11,12]] == [0,2.5,3,5,7,9]-arithmetic_mean :: Fractional a => [a] -> a-arithmetic_mean x = sum x / fromIntegral (length x)---- | Numerically stable mean------ > map ns_mean [[-3..3],[0..5],[1..5],[3,5,7],[7,7],[3,9,10,11,12]] == [0,2.5,3,5,7,9]-ns_mean :: Floating a => [a] -> a-ns_mean =-    let f (m,n) x = (m + (x - m) / (n + 1),n + 1)-    in fst . foldl' f (0,0)---- | Square of /n/.------ > square 5 == 25-square :: Num a => a -> a-square n = n * n---- | The totient function phi(n), also called Euler's totient function.------ > import Sound.SC3.Plot {- hsc3-plot -}--- > plot_p1_stp [map totient [1::Int .. 100]]-totient :: Integral i => i -> i-totient n = genericLength (filter (==1) (map (gcd n) [1..n]))--{- | The /n/-th order Farey sequence.--> farey 1 == [0,                                                                                    1]-> farey 2 == [0,                                        1/2,                                        1]-> farey 3 == [0,                        1/3,            1/2,            2/3,                        1]-> farey 4 == [0,                1/4,    1/3,            1/2,            2/3,    3/4,                1]-> farey 5 == [0,            1/5,1/4,    1/3,    2/5,    1/2,    3/5,    2/3,    3/4,4/5,            1]-> farey 6 == [0,        1/6,1/5,1/4,    1/3,    2/5,    1/2,    3/5,    2/3,    3/4,4/5,5/6,        1]-> farey 7 == [0,    1/7,1/6,1/5,1/4,2/7,1/3,    2/5,3/7,1/2,4/7,3/5,    2/3,5/7,3/4,4/5,5/6,6/7,    1]-> farey 8 == [0,1/8,1/7,1/6,1/5,1/4,2/7,1/3,3/8,2/5,3/7,1/2,4/7,3/5,5/8,2/3,5/7,3/4,4/5,5/6,6/7,7/8,1]--}-farey :: Integral i => i -> [Ratio i]-farey n =-  let step (a,b,c,d) =-        if c > n-        then Nothing-        else let k = (n + b) `quot` d in Just (c % d, (c,d,k * c - a,k * d - b))-  in 0 : unfoldr step (0,1,1,n)---- | The length of the /n/-th order Farey sequence.------ > map farey_length [1 .. 12] == [2,3,5,7,11,13,19,23,29,33,43,47]--- > map (length . farey) [1 .. 12] == map farey_length [1 .. 12]-farey_length :: Integral i => i -> i-farey_length n = if n == 0 then 1 else farey_length (n - 1) + totient n---- | Function to generate the Stern-Brocot tree from an initial row.---   '%' normalises so 1/0 cannot be written as a 'Rational', hence (n,d).-stern_brocot_tree_f :: Num n => [(n,n)] -> [[(n,n)]]-stern_brocot_tree_f =-   let med_f (n1,d1) (n2,d2) = (n1 + n2,d1 + d2)-       f x = concat (transpose [x, zipWith med_f x (tail x)])-   in iterate f--{- | The Stern-Brocot tree from (0/1,1/0).--> let t = stern_brocot_tree-> t !! 0 == [(0,1),(1,0)]-> t !! 1 == [(0,1),(1,1),(1,0)]-> t !! 2 == [(0,1),(1,2),(1,1),(2,1),(1,0)]-> t !! 3 == [(0,1),(1,3),(1,2),(2,3),(1,1),(3,2),(2,1),(3,1),(1,0)]--> map length (take 12 stern_brocot_tree) == [2,3,5,9,17,33,65,129,257,513,1025,2049] -- A000051--}-stern_brocot_tree :: Num n => [[(n,n)]]-stern_brocot_tree = stern_brocot_tree_f [(0,1),(1,0)]---- | Left-hand (rational) side of the the Stern-Brocot tree, ie, from (0/1,1/1).-stern_brocot_tree_lhs :: Num n => [[(n,n)]]-stern_brocot_tree_lhs = stern_brocot_tree_f [(0,1),(1,1)]--{- | 'stern_brocot_tree_f' as 'Ratio's, for finite subsets.--> let t = stern_brocot_tree_f_r [0,1]-> t !! 1 == [0,1/2,1]-> t !! 2 == [0,1/3,1/2,2/3,1]-> t !! 3 == [0,1/4,1/3,2/5,1/2,3/5,2/3,3/4,1]-> t !! 4 == [0,1/5,1/4,2/7,1/3,3/8,2/5,3/7,1/2,4/7,3/5,5/8,2/3,5/7,3/4,4/5,1]--}-stern_brocot_tree_f_r :: Integral n => [Ratio n] -> [[Ratio n]]-stern_brocot_tree_f_r = map (map (uncurry (%))) . stern_brocot_tree_f . map rational_nd
− Music/Theory/Math/Convert.hs 
@@ -1,1125 +0,0 @@-{- | Specialised type conversions, see mk/mk-convert.hs--> map int_to_word8 [-1,0,255,256] == [255,0,255,0]-> map int_to_word8_maybe [-1,0,255,256] == [Nothing,Just 0,Just 255,Nothing]--> map integer_to_int64_maybe [-2 ^ 63 - 1,2 ^ 63] == [Nothing,Nothing]-> map integer_to_word64_maybe [2 ^ 64 - 1,2 ^ 64] == [Just 18446744073709551615,Nothing]--> map int16_to_float [-1,0,1] == [-1,0,1]---}-module Music.Theory.Math.Convert where--import Data.Int {- base -}-import Data.Word {- base -}---- * 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---- | Type specialised 'realToFrac'-double_to_float :: Double -> Float-double_to_float = realToFrac---- | Type specialised 'realToFrac'-float_to_double :: Float -> Double-float_to_double = realToFrac---- AUTOGEN (see mk/mk-convert.hs)---- | Type specialised 'fromIntegral'-word8_to_word16 :: Word8 -> Word16-word8_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_word32 :: Word8 -> Word32-word8_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_word64 :: Word8 -> Word64-word8_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_int8 :: Word8 -> Int8-word8_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_int16 :: Word8 -> Int16-word8_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_int32 :: Word8 -> Int32-word8_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_int64 :: Word8 -> Int64-word8_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_int :: Word8 -> Int-word8_to_int = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_integer :: Word8 -> Integer-word8_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_float :: Word8 -> Float-word8_to_float = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_double :: Word8 -> Double-word8_to_double = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_word8 :: Word16 -> Word8-word16_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_word32 :: Word16 -> Word32-word16_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_word64 :: Word16 -> Word64-word16_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_int8 :: Word16 -> Int8-word16_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_int16 :: Word16 -> Int16-word16_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_int32 :: Word16 -> Int32-word16_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_int64 :: Word16 -> Int64-word16_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_int :: Word16 -> Int-word16_to_int = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_integer :: Word16 -> Integer-word16_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_float :: Word16 -> Float-word16_to_float = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_double :: Word16 -> Double-word16_to_double = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_word8 :: Word32 -> Word8-word32_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_word16 :: Word32 -> Word16-word32_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_word64 :: Word32 -> Word64-word32_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int8 :: Word32 -> Int8-word32_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int16 :: Word32 -> Int16-word32_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int32 :: Word32 -> Int32-word32_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int64 :: Word32 -> Int64-word32_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int :: Word32 -> Int-word32_to_int = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_integer :: Word32 -> Integer-word32_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_float :: Word32 -> Float-word32_to_float = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_double :: Word32 -> Double-word32_to_double = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_word8 :: Word64 -> Word8-word64_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_word16 :: Word64 -> Word16-word64_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_word32 :: Word64 -> Word32-word64_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_int8 :: Word64 -> Int8-word64_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_int16 :: Word64 -> Int16-word64_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_int32 :: Word64 -> Int32-word64_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_int64 :: Word64 -> Int64-word64_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_int :: Word64 -> Int-word64_to_int = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_integer :: Word64 -> Integer-word64_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_float :: Word64 -> Float-word64_to_float = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_double :: Word64 -> Double-word64_to_double = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_word8 :: Int8 -> Word8-int8_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_word16 :: Int8 -> Word16-int8_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_word32 :: Int8 -> Word32-int8_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_word64 :: Int8 -> Word64-int8_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_int16 :: Int8 -> Int16-int8_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_int32 :: Int8 -> Int32-int8_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_int64 :: Int8 -> Int64-int8_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_int :: Int8 -> Int-int8_to_int = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_integer :: Int8 -> Integer-int8_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_float :: Int8 -> Float-int8_to_float = fromIntegral---- | Type specialised 'fromIntegral'-int8_to_double :: Int8 -> Double-int8_to_double = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_word8 :: Int16 -> Word8-int16_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_word16 :: Int16 -> Word16-int16_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_word32 :: Int16 -> Word32-int16_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_word64 :: Int16 -> Word64-int16_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_int8 :: Int16 -> Int8-int16_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_int32 :: Int16 -> Int32-int16_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_int64 :: Int16 -> Int64-int16_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_int :: Int16 -> Int-int16_to_int = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_integer :: Int16 -> Integer-int16_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_float :: Int16 -> Float-int16_to_float = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_double :: Int16 -> Double-int16_to_double = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_word8 :: Int32 -> Word8-int32_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_word16 :: Int32 -> Word16-int32_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_word32 :: Int32 -> Word32-int32_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_word64 :: Int32 -> Word64-int32_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_int8 :: Int32 -> Int8-int32_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_int16 :: Int32 -> Int16-int32_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_int64 :: Int32 -> Int64-int32_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_int :: Int32 -> Int-int32_to_int = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_integer :: Int32 -> Integer-int32_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_float :: Int32 -> Float-int32_to_float = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_double :: Int32 -> Double-int32_to_double = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_word8 :: Int64 -> Word8-int64_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_word16 :: Int64 -> Word16-int64_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_word32 :: Int64 -> Word32-int64_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_word64 :: Int64 -> Word64-int64_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_int8 :: Int64 -> Int8-int64_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_int16 :: Int64 -> Int16-int64_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_int32 :: Int64 -> Int32-int64_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_int :: Int64 -> Int-int64_to_int = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_integer :: Int64 -> Integer-int64_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_float :: Int64 -> Float-int64_to_float = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_double :: Int64 -> Double-int64_to_double = fromIntegral---- | Type specialised 'fromIntegral'-int_to_word8 :: Int -> Word8-int_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_word16 :: Int -> Word16-int_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_word32 :: Int -> Word32-int_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_word64 :: Int -> Word64-int_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int8 :: Int -> Int8-int_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int16 :: Int -> Int16-int_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int32 :: Int -> Int32-int_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int64 :: Int -> Int64-int_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_integer :: Int -> Integer-int_to_integer = fromIntegral---- | Type specialised 'fromIntegral'-int_to_float :: Int -> Float-int_to_float = fromIntegral---- | Type specialised 'fromIntegral'-int_to_double :: Int -> Double-int_to_double = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_word8 :: Integer -> Word8-integer_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_word16 :: Integer -> Word16-integer_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_word32 :: Integer -> Word32-integer_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_word64 :: Integer -> Word64-integer_to_word64 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_int8 :: Integer -> Int8-integer_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_int16 :: Integer -> Int16-integer_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_int32 :: Integer -> Int32-integer_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_int64 :: Integer -> Int64-integer_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_int :: Integer -> Int-integer_to_int = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_float :: Integer -> Float-integer_to_float = fromIntegral---- | Type specialised 'fromIntegral'-integer_to_double :: Integer -> Double-integer_to_double = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_word16_maybe :: Word8 -> Maybe Word16-word8_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word8_to_word32_maybe :: Word8 -> Maybe Word32-word8_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word8_to_word64_maybe :: Word8 -> Maybe Word64-word8_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word8_to_int8_maybe :: Word8 -> Maybe Int8-word8_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word8_to_int16_maybe :: Word8 -> Maybe Int16-word8_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word8_to_int32_maybe :: Word8 -> Maybe Int32-word8_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word8_to_int64_maybe :: Word8 -> Maybe Int64-word8_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word8_to_int_maybe :: Word8 -> Maybe Int-word8_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_word8_maybe :: Word16 -> Maybe Word8-word16_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_word32_maybe :: Word16 -> Maybe Word32-word16_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_word64_maybe :: Word16 -> Maybe Word64-word16_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_int8_maybe :: Word16 -> Maybe Int8-word16_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_int16_maybe :: Word16 -> Maybe Int16-word16_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_int32_maybe :: Word16 -> Maybe Int32-word16_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_int64_maybe :: Word16 -> Maybe Int64-word16_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word16_to_int_maybe :: Word16 -> Maybe Int-word16_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_word8_maybe :: Word32 -> Maybe Word8-word32_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_word16_maybe :: Word32 -> Maybe Word16-word32_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_word64_maybe :: Word32 -> Maybe Word64-word32_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_int8_maybe :: Word32 -> Maybe Int8-word32_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_int16_maybe :: Word32 -> Maybe Int16-word32_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_int32_maybe :: Word32 -> Maybe Int32-word32_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_int64_maybe :: Word32 -> Maybe Int64-word32_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word32_to_int_maybe :: Word32 -> Maybe Int-word32_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_word8_maybe :: Word64 -> Maybe Word8-word64_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_word16_maybe :: Word64 -> Maybe Word16-word64_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_word32_maybe :: Word64 -> Maybe Word32-word64_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_int8_maybe :: Word64 -> Maybe Int8-word64_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_int16_maybe :: Word64 -> Maybe Int16-word64_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_int32_maybe :: Word64 -> Maybe Int32-word64_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_int64_maybe :: Word64 -> Maybe Int64-word64_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-word64_to_int_maybe :: Word64 -> Maybe Int-word64_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_word8_maybe :: Int8 -> Maybe Word8-int8_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_word16_maybe :: Int8 -> Maybe Word16-int8_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_word32_maybe :: Int8 -> Maybe Word32-int8_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_word64_maybe :: Int8 -> Maybe Word64-int8_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_int16_maybe :: Int8 -> Maybe Int16-int8_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_int32_maybe :: Int8 -> Maybe Int32-int8_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_int64_maybe :: Int8 -> Maybe Int64-int8_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int8_to_int_maybe :: Int8 -> Maybe Int-int8_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_word8_maybe :: Int16 -> Maybe Word8-int16_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_word16_maybe :: Int16 -> Maybe Word16-int16_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_word32_maybe :: Int16 -> Maybe Word32-int16_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_word64_maybe :: Int16 -> Maybe Word64-int16_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_int8_maybe :: Int16 -> Maybe Int8-int16_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_int32_maybe :: Int16 -> Maybe Int32-int16_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_int64_maybe :: Int16 -> Maybe Int64-int16_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int16_to_int_maybe :: Int16 -> Maybe Int-int16_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_word8_maybe :: Int32 -> Maybe Word8-int32_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_word16_maybe :: Int32 -> Maybe Word16-int32_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_word32_maybe :: Int32 -> Maybe Word32-int32_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_word64_maybe :: Int32 -> Maybe Word64-int32_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_int8_maybe :: Int32 -> Maybe Int8-int32_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_int16_maybe :: Int32 -> Maybe Int16-int32_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_int64_maybe :: Int32 -> Maybe Int64-int32_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int32_to_int_maybe :: Int32 -> Maybe Int-int32_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_word8_maybe :: Int64 -> Maybe Word8-int64_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_word16_maybe :: Int64 -> Maybe Word16-int64_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_word32_maybe :: Int64 -> Maybe Word32-int64_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_word64_maybe :: Int64 -> Maybe Word64-int64_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_int8_maybe :: Int64 -> Maybe Int8-int64_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_int16_maybe :: Int64 -> Maybe Int16-int64_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_int32_maybe :: Int64 -> Maybe Int32-int64_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int64_to_int_maybe :: Int64 -> Maybe Int-int64_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_word8_maybe :: Int -> Maybe Word8-int_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_word16_maybe :: Int -> Maybe Word16-int_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_word32_maybe :: Int -> Maybe Word32-int_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_word64_maybe :: Int -> Maybe Word64-int_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_int8_maybe :: Int -> Maybe Int8-int_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_int16_maybe :: Int -> Maybe Int16-int_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_int32_maybe :: Int -> Maybe Int32-int_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-int_to_int64_maybe :: Int -> Maybe Int64-int_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_word8_maybe :: Integer -> Maybe Word8-integer_to_word8_maybe n =-    if n < fromIntegral (minBound::Word8) ||-       n > fromIntegral (maxBound::Word8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_word16_maybe :: Integer -> Maybe Word16-integer_to_word16_maybe n =-    if n < fromIntegral (minBound::Word16) ||-       n > fromIntegral (maxBound::Word16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_word32_maybe :: Integer -> Maybe Word32-integer_to_word32_maybe n =-    if n < fromIntegral (minBound::Word32) ||-       n > fromIntegral (maxBound::Word32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_word64_maybe :: Integer -> Maybe Word64-integer_to_word64_maybe n =-    if n < fromIntegral (minBound::Word64) ||-       n > fromIntegral (maxBound::Word64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_int8_maybe :: Integer -> Maybe Int8-integer_to_int8_maybe n =-    if n < fromIntegral (minBound::Int8) ||-       n > fromIntegral (maxBound::Int8)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_int16_maybe :: Integer -> Maybe Int16-integer_to_int16_maybe n =-    if n < fromIntegral (minBound::Int16) ||-       n > fromIntegral (maxBound::Int16)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_int32_maybe :: Integer -> Maybe Int32-integer_to_int32_maybe n =-    if n < fromIntegral (minBound::Int32) ||-       n > fromIntegral (maxBound::Int32)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_int64_maybe :: Integer -> Maybe Int64-integer_to_int64_maybe n =-    if n < fromIntegral (minBound::Int64) ||-       n > fromIntegral (maxBound::Int64)-    then Nothing-    else Just (fromIntegral n)---- | Type specialised 'fromIntegral'-integer_to_int_maybe :: Integer -> Maybe Int-integer_to_int_maybe n =-    if n < fromIntegral (minBound::Int) ||-       n > fromIntegral (maxBound::Int)-    then Nothing-    else Just (fromIntegral n)
− Music/Theory/Math/Convert/FX.hs 
@@ -1,1288 +0,0 @@--- | Conversion between SIGNED and SIZED integral types with bounds checking.---   Types are aliased as Ux and Ix.---   Includes sizes 4 (MIDI), 7 (ASCII,MIDI), 12 (SND,AKAI), 14 (MIDI) and 24 (SND).---   AUTOGENERATED: SEE mk/mk-convert.hs.-module Music.Theory.Math.Convert.FX where--import Data.Int {- base -}-import Data.Word {- base -}---- AUTOGEN---- | Alias-type U4 = Word8---- | Alias-type U7 = Word8---- | Alias-type U8 = Word8---- | Alias-type U12 = Word16---- | Alias-type U14 = Word16---- | Alias-type U16 = Word16---- | Alias-type U24 = Word32---- | Alias-type U32 = Word32---- | Alias-type U64 = Word64---- | Alias-type I4 = Int8---- | Alias-type I7 = Int8---- | Alias-type I8 = Int8---- | Alias-type I12 = Int16---- | Alias-type I14 = Int16---- | Alias-type I16 = Int16---- | Alias-type I24 = Int32---- | Alias-type I32 = Int32---- | Alias-type I64 = Int64---- | Type specialised 'fromIntegral'-u4_to_u7 :: U4 -> U7-u4_to_u7 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_u8 :: U4 -> U8-u4_to_u8 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_u12 :: U4 -> U12-u4_to_u12 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_u14 :: U4 -> U14-u4_to_u14 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_u16 :: U4 -> U16-u4_to_u16 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_u24 :: U4 -> U24-u4_to_u24 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_u32 :: U4 -> U32-u4_to_u32 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_u64 :: U4 -> U64-u4_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u4_to_i4 :: U4 -> I4-u4_to_i4 x = if x < 0 || x > 7 then error "u4_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u4_to_i7 :: U4 -> I7-u4_to_i7 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_i8 :: U4 -> I8-u4_to_i8 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_i12 :: U4 -> I12-u4_to_i12 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_i14 :: U4 -> I14-u4_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_i16 :: U4 -> I16-u4_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_i24 :: U4 -> I24-u4_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_i32 :: U4 -> I32-u4_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-u4_to_i64 :: U4 -> I64-u4_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u7_to_u4 :: U7 -> U4-u7_to_u4 x = if x < 0 || x > 15 then error "u7_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u7_to_u8 :: U7 -> U8-u7_to_u8 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_u12 :: U7 -> U12-u7_to_u12 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_u14 :: U7 -> U14-u7_to_u14 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_u16 :: U7 -> U16-u7_to_u16 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_u24 :: U7 -> U24-u7_to_u24 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_u32 :: U7 -> U32-u7_to_u32 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_u64 :: U7 -> U64-u7_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u7_to_i4 :: U7 -> I4-u7_to_i4 x = if x < 0 || x > 7 then error "u7_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u7_to_i7 :: U7 -> I7-u7_to_i7 x = if x < 0 || x > 63 then error "u7_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u7_to_i8 :: U7 -> I8-u7_to_i8 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_i12 :: U7 -> I12-u7_to_i12 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_i14 :: U7 -> I14-u7_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_i16 :: U7 -> I16-u7_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_i24 :: U7 -> I24-u7_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_i32 :: U7 -> I32-u7_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-u7_to_i64 :: U7 -> I64-u7_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u8_to_u4 :: U8 -> U4-u8_to_u4 x = if x < 0 || x > 15 then error "u8_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u8_to_u7 :: U8 -> U7-u8_to_u7 x = if x < 0 || x > 127 then error "u8_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u8_to_u12 :: U8 -> U12-u8_to_u12 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_u14 :: U8 -> U14-u8_to_u14 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_u16 :: U8 -> U16-u8_to_u16 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_u24 :: U8 -> U24-u8_to_u24 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_u32 :: U8 -> U32-u8_to_u32 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_u64 :: U8 -> U64-u8_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u8_to_i4 :: U8 -> I4-u8_to_i4 x = if x < 0 || x > 7 then error "u8_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u8_to_i7 :: U8 -> I7-u8_to_i7 x = if x < 0 || x > 63 then error "u8_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u8_to_i8 :: U8 -> I8-u8_to_i8 x = if x < 0 || x > 127 then error "u8_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u8_to_i12 :: U8 -> I12-u8_to_i12 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_i14 :: U8 -> I14-u8_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_i16 :: U8 -> I16-u8_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_i24 :: U8 -> I24-u8_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_i32 :: U8 -> I32-u8_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-u8_to_i64 :: U8 -> I64-u8_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u12_to_u4 :: U12 -> U4-u12_to_u4 x = if x < 0 || x > 15 then error "u12_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u12_to_u7 :: U12 -> U7-u12_to_u7 x = if x < 0 || x > 127 then error "u12_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u12_to_u8 :: U12 -> U8-u12_to_u8 x = if x < 0 || x > 255 then error "u12_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u12_to_u14 :: U12 -> U14-u12_to_u14 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_u16 :: U12 -> U16-u12_to_u16 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_u24 :: U12 -> U24-u12_to_u24 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_u32 :: U12 -> U32-u12_to_u32 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_u64 :: U12 -> U64-u12_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u12_to_i4 :: U12 -> I4-u12_to_i4 x = if x < 0 || x > 7 then error "u12_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u12_to_i7 :: U12 -> I7-u12_to_i7 x = if x < 0 || x > 63 then error "u12_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u12_to_i8 :: U12 -> I8-u12_to_i8 x = if x < 0 || x > 127 then error "u12_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u12_to_i12 :: U12 -> I12-u12_to_i12 x = if x < 0 || x > 2047 then error "u12_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u12_to_i14 :: U12 -> I14-u12_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_i16 :: U12 -> I16-u12_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_i24 :: U12 -> I24-u12_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_i32 :: U12 -> I32-u12_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-u12_to_i64 :: U12 -> I64-u12_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_u4 :: U14 -> U4-u14_to_u4 x = if x < 0 || x > 15 then error "u14_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_u7 :: U14 -> U7-u14_to_u7 x = if x < 0 || x > 127 then error "u14_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_u8 :: U14 -> U8-u14_to_u8 x = if x < 0 || x > 255 then error "u14_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_u12 :: U14 -> U12-u14_to_u12 x = if x < 0 || x > 4095 then error "u14_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u14_to_u16 :: U14 -> U16-u14_to_u16 = fromIntegral---- | Type specialised 'fromIntegral'-u14_to_u24 :: U14 -> U24-u14_to_u24 = fromIntegral---- | Type specialised 'fromIntegral'-u14_to_u32 :: U14 -> U32-u14_to_u32 = fromIntegral---- | Type specialised 'fromIntegral'-u14_to_u64 :: U14 -> U64-u14_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_i4 :: U14 -> I4-u14_to_i4 x = if x < 0 || x > 7 then error "u14_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_i7 :: U14 -> I7-u14_to_i7 x = if x < 0 || x > 63 then error "u14_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_i8 :: U14 -> I8-u14_to_i8 x = if x < 0 || x > 127 then error "u14_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_i12 :: U14 -> I12-u14_to_i12 x = if x < 0 || x > 2047 then error "u14_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u14_to_i14 :: U14 -> I14-u14_to_i14 x = if x < 0 || x > 8191 then error "u14_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u14_to_i16 :: U14 -> I16-u14_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-u14_to_i24 :: U14 -> I24-u14_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-u14_to_i32 :: U14 -> I32-u14_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-u14_to_i64 :: U14 -> I64-u14_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_u4 :: U16 -> U4-u16_to_u4 x = if x < 0 || x > 15 then error "u16_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_u7 :: U16 -> U7-u16_to_u7 x = if x < 0 || x > 127 then error "u16_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_u8 :: U16 -> U8-u16_to_u8 x = if x < 0 || x > 255 then error "u16_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_u12 :: U16 -> U12-u16_to_u12 x = if x < 0 || x > 4095 then error "u16_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_u14 :: U16 -> U14-u16_to_u14 x = if x < 0 || x > 16383 then error "u16_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u16_to_u24 :: U16 -> U24-u16_to_u24 = fromIntegral---- | Type specialised 'fromIntegral'-u16_to_u32 :: U16 -> U32-u16_to_u32 = fromIntegral---- | Type specialised 'fromIntegral'-u16_to_u64 :: U16 -> U64-u16_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_i4 :: U16 -> I4-u16_to_i4 x = if x < 0 || x > 7 then error "u16_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_i7 :: U16 -> I7-u16_to_i7 x = if x < 0 || x > 63 then error "u16_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_i8 :: U16 -> I8-u16_to_i8 x = if x < 0 || x > 127 then error "u16_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_i12 :: U16 -> I12-u16_to_i12 x = if x < 0 || x > 2047 then error "u16_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_i14 :: U16 -> I14-u16_to_i14 x = if x < 0 || x > 8191 then error "u16_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u16_to_i16 :: U16 -> I16-u16_to_i16 x = if x < 0 || x > 32767 then error "u16_to_i16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u16_to_i24 :: U16 -> I24-u16_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-u16_to_i32 :: U16 -> I32-u16_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-u16_to_i64 :: U16 -> I64-u16_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_u4 :: U24 -> U4-u24_to_u4 x = if x < 0 || x > 15 then error "u24_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_u7 :: U24 -> U7-u24_to_u7 x = if x < 0 || x > 127 then error "u24_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_u8 :: U24 -> U8-u24_to_u8 x = if x < 0 || x > 255 then error "u24_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_u12 :: U24 -> U12-u24_to_u12 x = if x < 0 || x > 4095 then error "u24_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_u14 :: U24 -> U14-u24_to_u14 x = if x < 0 || x > 16383 then error "u24_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_u16 :: U24 -> U16-u24_to_u16 x = if x < 0 || x > 65535 then error "u24_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u24_to_u32 :: U24 -> U32-u24_to_u32 = fromIntegral---- | Type specialised 'fromIntegral'-u24_to_u64 :: U24 -> U64-u24_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_i4 :: U24 -> I4-u24_to_i4 x = if x < 0 || x > 7 then error "u24_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_i7 :: U24 -> I7-u24_to_i7 x = if x < 0 || x > 63 then error "u24_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_i8 :: U24 -> I8-u24_to_i8 x = if x < 0 || x > 127 then error "u24_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_i12 :: U24 -> I12-u24_to_i12 x = if x < 0 || x > 2047 then error "u24_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_i14 :: U24 -> I14-u24_to_i14 x = if x < 0 || x > 8191 then error "u24_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_i16 :: U24 -> I16-u24_to_i16 x = if x < 0 || x > 32767 then error "u24_to_i16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u24_to_i24 :: U24 -> I24-u24_to_i24 x = if x < 0 || x > 8388607 then error "u24_to_i24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u24_to_i32 :: U24 -> I32-u24_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-u24_to_i64 :: U24 -> I64-u24_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_u4 :: U32 -> U4-u32_to_u4 x = if x < 0 || x > 15 then error "u32_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_u7 :: U32 -> U7-u32_to_u7 x = if x < 0 || x > 127 then error "u32_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_u8 :: U32 -> U8-u32_to_u8 x = if x < 0 || x > 255 then error "u32_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_u12 :: U32 -> U12-u32_to_u12 x = if x < 0 || x > 4095 then error "u32_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_u14 :: U32 -> U14-u32_to_u14 x = if x < 0 || x > 16383 then error "u32_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_u16 :: U32 -> U16-u32_to_u16 x = if x < 0 || x > 65535 then error "u32_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_u24 :: U32 -> U24-u32_to_u24 x = if x < 0 || x > 16777215 then error "u32_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u32_to_u64 :: U32 -> U64-u32_to_u64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i4 :: U32 -> I4-u32_to_i4 x = if x < 0 || x > 7 then error "u32_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i7 :: U32 -> I7-u32_to_i7 x = if x < 0 || x > 63 then error "u32_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i8 :: U32 -> I8-u32_to_i8 x = if x < 0 || x > 127 then error "u32_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i12 :: U32 -> I12-u32_to_i12 x = if x < 0 || x > 2047 then error "u32_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i14 :: U32 -> I14-u32_to_i14 x = if x < 0 || x > 8191 then error "u32_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i16 :: U32 -> I16-u32_to_i16 x = if x < 0 || x > 32767 then error "u32_to_i16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i24 :: U32 -> I24-u32_to_i24 x = if x < 0 || x > 8388607 then error "u32_to_i24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u32_to_i32 :: U32 -> I32-u32_to_i32 x = if x < 0 || x > 2147483647 then error "u32_to_i32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-u32_to_i64 :: U32 -> I64-u32_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u4 :: U64 -> U4-u64_to_u4 x = if x < 0 || x > 15 then error "u64_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u7 :: U64 -> U7-u64_to_u7 x = if x < 0 || x > 127 then error "u64_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u8 :: U64 -> U8-u64_to_u8 x = if x < 0 || x > 255 then error "u64_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u12 :: U64 -> U12-u64_to_u12 x = if x < 0 || x > 4095 then error "u64_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u14 :: U64 -> U14-u64_to_u14 x = if x < 0 || x > 16383 then error "u64_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u16 :: U64 -> U16-u64_to_u16 x = if x < 0 || x > 65535 then error "u64_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u24 :: U64 -> U24-u64_to_u24 x = if x < 0 || x > 16777215 then error "u64_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_u32 :: U64 -> U32-u64_to_u32 x = if x < 0 || x > 4294967295 then error "u64_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i4 :: U64 -> I4-u64_to_i4 x = if x < 0 || x > 7 then error "u64_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i7 :: U64 -> I7-u64_to_i7 x = if x < 0 || x > 63 then error "u64_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i8 :: U64 -> I8-u64_to_i8 x = if x < 0 || x > 127 then error "u64_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i12 :: U64 -> I12-u64_to_i12 x = if x < 0 || x > 2047 then error "u64_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i14 :: U64 -> I14-u64_to_i14 x = if x < 0 || x > 8191 then error "u64_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i16 :: U64 -> I16-u64_to_i16 x = if x < 0 || x > 32767 then error "u64_to_i16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i24 :: U64 -> I24-u64_to_i24 x = if x < 0 || x > 8388607 then error "u64_to_i24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i32 :: U64 -> I32-u64_to_i32 x = if x < 0 || x > 2147483647 then error "u64_to_i32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-u64_to_i64 :: U64 -> I64-u64_to_i64 x = if x < 0 || x > 9223372036854775807 then error "u64_to_i64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u4 :: I4 -> U4-i4_to_u4 x = if x < 0 then error "i4_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u7 :: I4 -> U7-i4_to_u7 x = if x < 0 then error "i4_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u8 :: I4 -> U8-i4_to_u8 x = if x < 0 then error "i4_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u12 :: I4 -> U12-i4_to_u12 x = if x < 0 then error "i4_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u14 :: I4 -> U14-i4_to_u14 x = if x < 0 then error "i4_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u16 :: I4 -> U16-i4_to_u16 x = if x < 0 then error "i4_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u24 :: I4 -> U24-i4_to_u24 x = if x < 0 then error "i4_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u32 :: I4 -> U32-i4_to_u32 x = if x < 0 then error "i4_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i4_to_u64 :: I4 -> U64-i4_to_u64 x = if x < 0 then error "i4_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i4_to_i7 :: I4 -> I7-i4_to_i7 = fromIntegral---- | Type specialised 'fromIntegral'-i4_to_i8 :: I4 -> I8-i4_to_i8 = fromIntegral---- | Type specialised 'fromIntegral'-i4_to_i12 :: I4 -> I12-i4_to_i12 = fromIntegral---- | Type specialised 'fromIntegral'-i4_to_i14 :: I4 -> I14-i4_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-i4_to_i16 :: I4 -> I16-i4_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-i4_to_i24 :: I4 -> I24-i4_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-i4_to_i32 :: I4 -> I32-i4_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-i4_to_i64 :: I4 -> I64-i4_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u4 :: I7 -> U4-i7_to_u4 x = if x < 0 || x > 15 then error "i7_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u7 :: I7 -> U7-i7_to_u7 x = if x < 0 then error "i7_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u8 :: I7 -> U8-i7_to_u8 x = if x < 0 then error "i7_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u12 :: I7 -> U12-i7_to_u12 x = if x < 0 then error "i7_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u14 :: I7 -> U14-i7_to_u14 x = if x < 0 then error "i7_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u16 :: I7 -> U16-i7_to_u16 x = if x < 0 then error "i7_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u24 :: I7 -> U24-i7_to_u24 x = if x < 0 then error "i7_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u32 :: I7 -> U32-i7_to_u32 x = if x < 0 then error "i7_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_u64 :: I7 -> U64-i7_to_u64 x = if x < 0 then error "i7_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i7_to_i4 :: I7 -> I4-i7_to_i4 x = if x < -8 || x > 7 then error "i7_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i7_to_i8 :: I7 -> I8-i7_to_i8 = fromIntegral---- | Type specialised 'fromIntegral'-i7_to_i12 :: I7 -> I12-i7_to_i12 = fromIntegral---- | Type specialised 'fromIntegral'-i7_to_i14 :: I7 -> I14-i7_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-i7_to_i16 :: I7 -> I16-i7_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-i7_to_i24 :: I7 -> I24-i7_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-i7_to_i32 :: I7 -> I32-i7_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-i7_to_i64 :: I7 -> I64-i7_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u4 :: I8 -> U4-i8_to_u4 x = if x < 0 || x > 15 then error "i8_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u7 :: I8 -> U7-i8_to_u7 x = if x < 0 || x > 127 then error "i8_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u8 :: I8 -> U8-i8_to_u8 x = if x < 0 then error "i8_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u12 :: I8 -> U12-i8_to_u12 x = if x < 0 then error "i8_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u14 :: I8 -> U14-i8_to_u14 x = if x < 0 then error "i8_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u16 :: I8 -> U16-i8_to_u16 x = if x < 0 then error "i8_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u24 :: I8 -> U24-i8_to_u24 x = if x < 0 then error "i8_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u32 :: I8 -> U32-i8_to_u32 x = if x < 0 then error "i8_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_u64 :: I8 -> U64-i8_to_u64 x = if x < 0 then error "i8_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_i4 :: I8 -> I4-i8_to_i4 x = if x < -8 || x > 7 then error "i8_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i8_to_i7 :: I8 -> I7-i8_to_i7 x = if x < -64 || x > 63 then error "i8_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i8_to_i12 :: I8 -> I12-i8_to_i12 = fromIntegral---- | Type specialised 'fromIntegral'-i8_to_i14 :: I8 -> I14-i8_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-i8_to_i16 :: I8 -> I16-i8_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-i8_to_i24 :: I8 -> I24-i8_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-i8_to_i32 :: I8 -> I32-i8_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-i8_to_i64 :: I8 -> I64-i8_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u4 :: I12 -> U4-i12_to_u4 x = if x < 0 || x > 15 then error "i12_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u7 :: I12 -> U7-i12_to_u7 x = if x < 0 || x > 127 then error "i12_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u8 :: I12 -> U8-i12_to_u8 x = if x < 0 || x > 255 then error "i12_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u12 :: I12 -> U12-i12_to_u12 x = if x < 0 then error "i12_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u14 :: I12 -> U14-i12_to_u14 x = if x < 0 then error "i12_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u16 :: I12 -> U16-i12_to_u16 x = if x < 0 then error "i12_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u24 :: I12 -> U24-i12_to_u24 x = if x < 0 then error "i12_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u32 :: I12 -> U32-i12_to_u32 x = if x < 0 then error "i12_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_u64 :: I12 -> U64-i12_to_u64 x = if x < 0 then error "i12_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_i4 :: I12 -> I4-i12_to_i4 x = if x < -8 || x > 7 then error "i12_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_i7 :: I12 -> I7-i12_to_i7 x = if x < -64 || x > 63 then error "i12_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i12_to_i8 :: I12 -> I8-i12_to_i8 x = if x < -128 || x > 127 then error "i12_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i12_to_i14 :: I12 -> I14-i12_to_i14 = fromIntegral---- | Type specialised 'fromIntegral'-i12_to_i16 :: I12 -> I16-i12_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-i12_to_i24 :: I12 -> I24-i12_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-i12_to_i32 :: I12 -> I32-i12_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-i12_to_i64 :: I12 -> I64-i12_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u4 :: I14 -> U4-i14_to_u4 x = if x < 0 || x > 15 then error "i14_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u7 :: I14 -> U7-i14_to_u7 x = if x < 0 || x > 127 then error "i14_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u8 :: I14 -> U8-i14_to_u8 x = if x < 0 || x > 255 then error "i14_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u12 :: I14 -> U12-i14_to_u12 x = if x < 0 || x > 4095 then error "i14_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u14 :: I14 -> U14-i14_to_u14 x = if x < 0 then error "i14_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u16 :: I14 -> U16-i14_to_u16 x = if x < 0 then error "i14_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u24 :: I14 -> U24-i14_to_u24 x = if x < 0 then error "i14_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u32 :: I14 -> U32-i14_to_u32 x = if x < 0 then error "i14_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_u64 :: I14 -> U64-i14_to_u64 x = if x < 0 then error "i14_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_i4 :: I14 -> I4-i14_to_i4 x = if x < -8 || x > 7 then error "i14_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_i7 :: I14 -> I7-i14_to_i7 x = if x < -64 || x > 63 then error "i14_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_i8 :: I14 -> I8-i14_to_i8 x = if x < -128 || x > 127 then error "i14_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i14_to_i12 :: I14 -> I12-i14_to_i12 x = if x < -2048 || x > 2047 then error "i14_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i14_to_i16 :: I14 -> I16-i14_to_i16 = fromIntegral---- | Type specialised 'fromIntegral'-i14_to_i24 :: I14 -> I24-i14_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-i14_to_i32 :: I14 -> I32-i14_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-i14_to_i64 :: I14 -> I64-i14_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u4 :: I16 -> U4-i16_to_u4 x = if x < 0 || x > 15 then error "i16_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u7 :: I16 -> U7-i16_to_u7 x = if x < 0 || x > 127 then error "i16_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u8 :: I16 -> U8-i16_to_u8 x = if x < 0 || x > 255 then error "i16_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u12 :: I16 -> U12-i16_to_u12 x = if x < 0 || x > 4095 then error "i16_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u14 :: I16 -> U14-i16_to_u14 x = if x < 0 || x > 16383 then error "i16_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u16 :: I16 -> U16-i16_to_u16 x = if x < 0 then error "i16_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u24 :: I16 -> U24-i16_to_u24 x = if x < 0 then error "i16_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u32 :: I16 -> U32-i16_to_u32 x = if x < 0 then error "i16_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_u64 :: I16 -> U64-i16_to_u64 x = if x < 0 then error "i16_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_i4 :: I16 -> I4-i16_to_i4 x = if x < -8 || x > 7 then error "i16_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_i7 :: I16 -> I7-i16_to_i7 x = if x < -64 || x > 63 then error "i16_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_i8 :: I16 -> I8-i16_to_i8 x = if x < -128 || x > 127 then error "i16_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_i12 :: I16 -> I12-i16_to_i12 x = if x < -2048 || x > 2047 then error "i16_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i16_to_i14 :: I16 -> I14-i16_to_i14 x = if x < -8192 || x > 8191 then error "i16_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i16_to_i24 :: I16 -> I24-i16_to_i24 = fromIntegral---- | Type specialised 'fromIntegral'-i16_to_i32 :: I16 -> I32-i16_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-i16_to_i64 :: I16 -> I64-i16_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u4 :: I24 -> U4-i24_to_u4 x = if x < 0 || x > 15 then error "i24_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u7 :: I24 -> U7-i24_to_u7 x = if x < 0 || x > 127 then error "i24_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u8 :: I24 -> U8-i24_to_u8 x = if x < 0 || x > 255 then error "i24_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u12 :: I24 -> U12-i24_to_u12 x = if x < 0 || x > 4095 then error "i24_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u14 :: I24 -> U14-i24_to_u14 x = if x < 0 || x > 16383 then error "i24_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u16 :: I24 -> U16-i24_to_u16 x = if x < 0 || x > 65535 then error "i24_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u24 :: I24 -> U24-i24_to_u24 x = if x < 0 then error "i24_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u32 :: I24 -> U32-i24_to_u32 x = if x < 0 then error "i24_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_u64 :: I24 -> U64-i24_to_u64 x = if x < 0 then error "i24_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_i4 :: I24 -> I4-i24_to_i4 x = if x < -8 || x > 7 then error "i24_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_i7 :: I24 -> I7-i24_to_i7 x = if x < -64 || x > 63 then error "i24_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_i8 :: I24 -> I8-i24_to_i8 x = if x < -128 || x > 127 then error "i24_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_i12 :: I24 -> I12-i24_to_i12 x = if x < -2048 || x > 2047 then error "i24_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_i14 :: I24 -> I14-i24_to_i14 x = if x < -8192 || x > 8191 then error "i24_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i24_to_i16 :: I24 -> I16-i24_to_i16 x = if x < -32768 || x > 32767 then error "i24_to_i16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i24_to_i32 :: I24 -> I32-i24_to_i32 = fromIntegral---- | Type specialised 'fromIntegral'-i24_to_i64 :: I24 -> I64-i24_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u4 :: I32 -> U4-i32_to_u4 x = if x < 0 || x > 15 then error "i32_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u7 :: I32 -> U7-i32_to_u7 x = if x < 0 || x > 127 then error "i32_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u8 :: I32 -> U8-i32_to_u8 x = if x < 0 || x > 255 then error "i32_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u12 :: I32 -> U12-i32_to_u12 x = if x < 0 || x > 4095 then error "i32_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u14 :: I32 -> U14-i32_to_u14 x = if x < 0 || x > 16383 then error "i32_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u16 :: I32 -> U16-i32_to_u16 x = if x < 0 || x > 65535 then error "i32_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u24 :: I32 -> U24-i32_to_u24 x = if x < 0 || x > 16777215 then error "i32_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u32 :: I32 -> U32-i32_to_u32 x = if x < 0 then error "i32_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_u64 :: I32 -> U64-i32_to_u64 x = if x < 0 then error "i32_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_i4 :: I32 -> I4-i32_to_i4 x = if x < -8 || x > 7 then error "i32_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_i7 :: I32 -> I7-i32_to_i7 x = if x < -64 || x > 63 then error "i32_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_i8 :: I32 -> I8-i32_to_i8 x = if x < -128 || x > 127 then error "i32_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_i12 :: I32 -> I12-i32_to_i12 x = if x < -2048 || x > 2047 then error "i32_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_i14 :: I32 -> I14-i32_to_i14 x = if x < -8192 || x > 8191 then error "i32_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_i16 :: I32 -> I16-i32_to_i16 x = if x < -32768 || x > 32767 then error "i32_to_i16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i32_to_i24 :: I32 -> I24-i32_to_i24 x = if x < -8388608 || x > 8388607 then error "i32_to_i24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral'-i32_to_i64 :: I32 -> I64-i32_to_i64 = fromIntegral---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u4 :: I64 -> U4-i64_to_u4 x = if x < 0 || x > 15 then error "i64_to_u4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u7 :: I64 -> U7-i64_to_u7 x = if x < 0 || x > 127 then error "i64_to_u7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u8 :: I64 -> U8-i64_to_u8 x = if x < 0 || x > 255 then error "i64_to_u8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u12 :: I64 -> U12-i64_to_u12 x = if x < 0 || x > 4095 then error "i64_to_u12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u14 :: I64 -> U14-i64_to_u14 x = if x < 0 || x > 16383 then error "i64_to_u14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u16 :: I64 -> U16-i64_to_u16 x = if x < 0 || x > 65535 then error "i64_to_u16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u24 :: I64 -> U24-i64_to_u24 x = if x < 0 || x > 16777215 then error "i64_to_u24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u32 :: I64 -> U32-i64_to_u32 x = if x < 0 || x > 4294967295 then error "i64_to_u32: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_u64 :: I64 -> U64-i64_to_u64 x = if x < 0 then error "i64_to_u64: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i4 :: I64 -> I4-i64_to_i4 x = if x < -8 || x > 7 then error "i64_to_i4: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i7 :: I64 -> I7-i64_to_i7 x = if x < -64 || x > 63 then error "i64_to_i7: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i8 :: I64 -> I8-i64_to_i8 x = if x < -128 || x > 127 then error "i64_to_i8: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i12 :: I64 -> I12-i64_to_i12 x = if x < -2048 || x > 2047 then error "i64_to_i12: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i14 :: I64 -> I14-i64_to_i14 x = if x < -8192 || x > 8191 then error "i64_to_i14: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i16 :: I64 -> I16-i64_to_i16 x = if x < -32768 || x > 32767 then error "i64_to_i16: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i24 :: I64 -> I24-i64_to_i24 x = if x < -8388608 || x > 8388607 then error "i64_to_i24: OUT-OF-RANGE" else fromIntegral x---- | Type specialised 'fromIntegral' with out-of-range error.-i64_to_i32 :: I64 -> I32-i64_to_i32 x = if x < -2147483648 || x > 2147483647 then error "i64_to_i32: OUT-OF-RANGE" else fromIntegral x
+ Music/Theory/Math/Convert/Fx.hs view
@@ -0,0 +1,1286 @@+-- | 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 -}++-- | Alias+type U4 = Word8++-- | Alias+type U7 = Word8++-- | Alias+type U8 = Word8++-- | Alias+type U12 = Word16++-- | Alias+type U14 = Word16++-- | Alias+type U16 = Word16++-- | Alias+type U24 = Word32++-- | Alias+type U32 = Word32++-- | Alias+type U64 = Word64++-- | Alias+type I4 = Int8++-- | Alias+type I7 = Int8++-- | Alias+type I8 = Int8++-- | Alias+type I12 = Int16++-- | Alias+type I14 = Int16++-- | Alias+type I16 = Int16++-- | Alias+type I24 = Int32++-- | Alias+type I32 = Int32++-- | Alias+type I64 = Int64++-- | Type specialised 'fromIntegral'+u4_to_u7 :: U4 -> U7+u4_to_u7 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u8 :: U4 -> U8+u4_to_u8 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u12 :: U4 -> U12+u4_to_u12 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u14 :: U4 -> U14+u4_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u16 :: U4 -> U16+u4_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u24 :: U4 -> U24+u4_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u32 :: U4 -> U32+u4_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_u64 :: U4 -> U64+u4_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u4_to_i4 :: U4 -> I4+u4_to_i4 x = if x < 0 || x > 7 then error "u4_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u4_to_i7 :: U4 -> I7+u4_to_i7 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i8 :: U4 -> I8+u4_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i12 :: U4 -> I12+u4_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i14 :: U4 -> I14+u4_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i16 :: U4 -> I16+u4_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i24 :: U4 -> I24+u4_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i32 :: U4 -> I32+u4_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u4_to_i64 :: U4 -> I64+u4_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u7_to_u4 :: U7 -> U4+u7_to_u4 x = if x < 0 || x > 15 then error "u7_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u7_to_u8 :: U7 -> U8+u7_to_u8 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u12 :: U7 -> U12+u7_to_u12 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u14 :: U7 -> U14+u7_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u16 :: U7 -> U16+u7_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u24 :: U7 -> U24+u7_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u32 :: U7 -> U32+u7_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_u64 :: U7 -> U64+u7_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u7_to_i4 :: U7 -> I4+u7_to_i4 x = if x < 0 || x > 7 then error "u7_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u7_to_i7 :: U7 -> I7+u7_to_i7 x = if x < 0 || x > 63 then error "u7_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u7_to_i8 :: U7 -> I8+u7_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i12 :: U7 -> I12+u7_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i14 :: U7 -> I14+u7_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i16 :: U7 -> I16+u7_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i24 :: U7 -> I24+u7_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i32 :: U7 -> I32+u7_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u7_to_i64 :: U7 -> I64+u7_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_u4 :: U8 -> U4+u8_to_u4 x = if x < 0 || x > 15 then error "u8_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_u7 :: U8 -> U7+u8_to_u7 x = if x < 0 || x > 127 then error "u8_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u8_to_u12 :: U8 -> U12+u8_to_u12 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u14 :: U8 -> U14+u8_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u16 :: U8 -> U16+u8_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u24 :: U8 -> U24+u8_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u32 :: U8 -> U32+u8_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_u64 :: U8 -> U64+u8_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_i4 :: U8 -> I4+u8_to_i4 x = if x < 0 || x > 7 then error "u8_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_i7 :: U8 -> I7+u8_to_i7 x = if x < 0 || x > 63 then error "u8_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u8_to_i8 :: U8 -> I8+u8_to_i8 x = if x < 0 || x > 127 then error "u8_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u8_to_i12 :: U8 -> I12+u8_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i14 :: U8 -> I14+u8_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i16 :: U8 -> I16+u8_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i24 :: U8 -> I24+u8_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i32 :: U8 -> I32+u8_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u8_to_i64 :: U8 -> I64+u8_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_u4 :: U12 -> U4+u12_to_u4 x = if x < 0 || x > 15 then error "u12_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_u7 :: U12 -> U7+u12_to_u7 x = if x < 0 || x > 127 then error "u12_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_u8 :: U12 -> U8+u12_to_u8 x = if x < 0 || x > 255 then error "u12_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u12_to_u14 :: U12 -> U14+u12_to_u14 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u16 :: U12 -> U16+u12_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u24 :: U12 -> U24+u12_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u32 :: U12 -> U32+u12_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_u64 :: U12 -> U64+u12_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i4 :: U12 -> I4+u12_to_i4 x = if x < 0 || x > 7 then error "u12_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i7 :: U12 -> I7+u12_to_i7 x = if x < 0 || x > 63 then error "u12_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i8 :: U12 -> I8+u12_to_i8 x = if x < 0 || x > 127 then error "u12_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u12_to_i12 :: U12 -> I12+u12_to_i12 x = if x < 0 || x > 2047 then error "u12_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u12_to_i14 :: U12 -> I14+u12_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i16 :: U12 -> I16+u12_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i24 :: U12 -> I24+u12_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i32 :: U12 -> I32+u12_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u12_to_i64 :: U12 -> I64+u12_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u4 :: U14 -> U4+u14_to_u4 x = if x < 0 || x > 15 then error "u14_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u7 :: U14 -> U7+u14_to_u7 x = if x < 0 || x > 127 then error "u14_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u8 :: U14 -> U8+u14_to_u8 x = if x < 0 || x > 255 then error "u14_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_u12 :: U14 -> U12+u14_to_u12 x = if x < 0 || x > 4095 then error "u14_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u14_to_u16 :: U14 -> U16+u14_to_u16 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_u24 :: U14 -> U24+u14_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_u32 :: U14 -> U32+u14_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_u64 :: U14 -> U64+u14_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i4 :: U14 -> I4+u14_to_i4 x = if x < 0 || x > 7 then error "u14_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i7 :: U14 -> I7+u14_to_i7 x = if x < 0 || x > 63 then error "u14_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i8 :: U14 -> I8+u14_to_i8 x = if x < 0 || x > 127 then error "u14_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i12 :: U14 -> I12+u14_to_i12 x = if x < 0 || x > 2047 then error "u14_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u14_to_i14 :: U14 -> I14+u14_to_i14 x = if x < 0 || x > 8191 then error "u14_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u14_to_i16 :: U14 -> I16+u14_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_i24 :: U14 -> I24+u14_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_i32 :: U14 -> I32+u14_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u14_to_i64 :: U14 -> I64+u14_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u4 :: U16 -> U4+u16_to_u4 x = if x < 0 || x > 15 then error "u16_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u7 :: U16 -> U7+u16_to_u7 x = if x < 0 || x > 127 then error "u16_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u8 :: U16 -> U8+u16_to_u8 x = if x < 0 || x > 255 then error "u16_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u12 :: U16 -> U12+u16_to_u12 x = if x < 0 || x > 4095 then error "u16_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_u14 :: U16 -> U14+u16_to_u14 x = if x < 0 || x > 16383 then error "u16_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u16_to_u24 :: U16 -> U24+u16_to_u24 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_u32 :: U16 -> U32+u16_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_u64 :: U16 -> U64+u16_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i4 :: U16 -> I4+u16_to_i4 x = if x < 0 || x > 7 then error "u16_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i7 :: U16 -> I7+u16_to_i7 x = if x < 0 || x > 63 then error "u16_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i8 :: U16 -> I8+u16_to_i8 x = if x < 0 || x > 127 then error "u16_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i12 :: U16 -> I12+u16_to_i12 x = if x < 0 || x > 2047 then error "u16_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i14 :: U16 -> I14+u16_to_i14 x = if x < 0 || x > 8191 then error "u16_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u16_to_i16 :: U16 -> I16+u16_to_i16 x = if x < 0 || x > 32767 then error "u16_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u16_to_i24 :: U16 -> I24+u16_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_i32 :: U16 -> I32+u16_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u16_to_i64 :: U16 -> I64+u16_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u4 :: U24 -> U4+u24_to_u4 x = if x < 0 || x > 15 then error "u24_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u7 :: U24 -> U7+u24_to_u7 x = if x < 0 || x > 127 then error "u24_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u8 :: U24 -> U8+u24_to_u8 x = if x < 0 || x > 255 then error "u24_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u12 :: U24 -> U12+u24_to_u12 x = if x < 0 || x > 4095 then error "u24_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u14 :: U24 -> U14+u24_to_u14 x = if x < 0 || x > 16383 then error "u24_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_u16 :: U24 -> U16+u24_to_u16 x = if x < 0 || x > 65535 then error "u24_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u24_to_u32 :: U24 -> U32+u24_to_u32 = fromIntegral++-- | Type specialised 'fromIntegral'+u24_to_u64 :: U24 -> U64+u24_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i4 :: U24 -> I4+u24_to_i4 x = if x < 0 || x > 7 then error "u24_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i7 :: U24 -> I7+u24_to_i7 x = if x < 0 || x > 63 then error "u24_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i8 :: U24 -> I8+u24_to_i8 x = if x < 0 || x > 127 then error "u24_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i12 :: U24 -> I12+u24_to_i12 x = if x < 0 || x > 2047 then error "u24_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i14 :: U24 -> I14+u24_to_i14 x = if x < 0 || x > 8191 then error "u24_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i16 :: U24 -> I16+u24_to_i16 x = if x < 0 || x > 32767 then error "u24_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u24_to_i24 :: U24 -> I24+u24_to_i24 x = if x < 0 || x > 8388607 then error "u24_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u24_to_i32 :: U24 -> I32+u24_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+u24_to_i64 :: U24 -> I64+u24_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u4 :: U32 -> U4+u32_to_u4 x = if x < 0 || x > 15 then error "u32_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u7 :: U32 -> U7+u32_to_u7 x = if x < 0 || x > 127 then error "u32_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u8 :: U32 -> U8+u32_to_u8 x = if x < 0 || x > 255 then error "u32_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u12 :: U32 -> U12+u32_to_u12 x = if x < 0 || x > 4095 then error "u32_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u14 :: U32 -> U14+u32_to_u14 x = if x < 0 || x > 16383 then error "u32_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u16 :: U32 -> U16+u32_to_u16 x = if x < 0 || x > 65535 then error "u32_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_u24 :: U32 -> U24+u32_to_u24 x = if x < 0 || x > 16777215 then error "u32_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u32_to_u64 :: U32 -> U64+u32_to_u64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i4 :: U32 -> I4+u32_to_i4 x = if x < 0 || x > 7 then error "u32_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i7 :: U32 -> I7+u32_to_i7 x = if x < 0 || x > 63 then error "u32_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i8 :: U32 -> I8+u32_to_i8 x = if x < 0 || x > 127 then error "u32_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i12 :: U32 -> I12+u32_to_i12 x = if x < 0 || x > 2047 then error "u32_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i14 :: U32 -> I14+u32_to_i14 x = if x < 0 || x > 8191 then error "u32_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i16 :: U32 -> I16+u32_to_i16 x = if x < 0 || x > 32767 then error "u32_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i24 :: U32 -> I24+u32_to_i24 x = if x < 0 || x > 8388607 then error "u32_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u32_to_i32 :: U32 -> I32+u32_to_i32 x = if x < 0 || x > 2147483647 then error "u32_to_i32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+u32_to_i64 :: U32 -> I64+u32_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u4 :: U64 -> U4+u64_to_u4 x = if x < 0 || x > 15 then error "u64_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u7 :: U64 -> U7+u64_to_u7 x = if x < 0 || x > 127 then error "u64_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u8 :: U64 -> U8+u64_to_u8 x = if x < 0 || x > 255 then error "u64_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u12 :: U64 -> U12+u64_to_u12 x = if x < 0 || x > 4095 then error "u64_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u14 :: U64 -> U14+u64_to_u14 x = if x < 0 || x > 16383 then error "u64_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u16 :: U64 -> U16+u64_to_u16 x = if x < 0 || x > 65535 then error "u64_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u24 :: U64 -> U24+u64_to_u24 x = if x < 0 || x > 16777215 then error "u64_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_u32 :: U64 -> U32+u64_to_u32 x = if x < 0 || x > 4294967295 then error "u64_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i4 :: U64 -> I4+u64_to_i4 x = if x < 0 || x > 7 then error "u64_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i7 :: U64 -> I7+u64_to_i7 x = if x < 0 || x > 63 then error "u64_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i8 :: U64 -> I8+u64_to_i8 x = if x < 0 || x > 127 then error "u64_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i12 :: U64 -> I12+u64_to_i12 x = if x < 0 || x > 2047 then error "u64_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i14 :: U64 -> I14+u64_to_i14 x = if x < 0 || x > 8191 then error "u64_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i16 :: U64 -> I16+u64_to_i16 x = if x < 0 || x > 32767 then error "u64_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i24 :: U64 -> I24+u64_to_i24 x = if x < 0 || x > 8388607 then error "u64_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i32 :: U64 -> I32+u64_to_i32 x = if x < 0 || x > 2147483647 then error "u64_to_i32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+u64_to_i64 :: U64 -> I64+u64_to_i64 x = if x < 0 || x > 9223372036854775807 then error "u64_to_i64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u4 :: I4 -> U4+i4_to_u4 x = if x < 0 then error "i4_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u7 :: I4 -> U7+i4_to_u7 x = if x < 0 then error "i4_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u8 :: I4 -> U8+i4_to_u8 x = if x < 0 then error "i4_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u12 :: I4 -> U12+i4_to_u12 x = if x < 0 then error "i4_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u14 :: I4 -> U14+i4_to_u14 x = if x < 0 then error "i4_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u16 :: I4 -> U16+i4_to_u16 x = if x < 0 then error "i4_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u24 :: I4 -> U24+i4_to_u24 x = if x < 0 then error "i4_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u32 :: I4 -> U32+i4_to_u32 x = if x < 0 then error "i4_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i4_to_u64 :: I4 -> U64+i4_to_u64 x = if x < 0 then error "i4_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i4_to_i7 :: I4 -> I7+i4_to_i7 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i8 :: I4 -> I8+i4_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i12 :: I4 -> I12+i4_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i14 :: I4 -> I14+i4_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i16 :: I4 -> I16+i4_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i24 :: I4 -> I24+i4_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i32 :: I4 -> I32+i4_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i4_to_i64 :: I4 -> I64+i4_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u4 :: I7 -> U4+i7_to_u4 x = if x < 0 || x > 15 then error "i7_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u7 :: I7 -> U7+i7_to_u7 x = if x < 0 then error "i7_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u8 :: I7 -> U8+i7_to_u8 x = if x < 0 then error "i7_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u12 :: I7 -> U12+i7_to_u12 x = if x < 0 then error "i7_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u14 :: I7 -> U14+i7_to_u14 x = if x < 0 then error "i7_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u16 :: I7 -> U16+i7_to_u16 x = if x < 0 then error "i7_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u24 :: I7 -> U24+i7_to_u24 x = if x < 0 then error "i7_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u32 :: I7 -> U32+i7_to_u32 x = if x < 0 then error "i7_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_u64 :: I7 -> U64+i7_to_u64 x = if x < 0 then error "i7_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i7_to_i4 :: I7 -> I4+i7_to_i4 x = if x < -8 || x > 7 then error "i7_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i7_to_i8 :: I7 -> I8+i7_to_i8 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i12 :: I7 -> I12+i7_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i14 :: I7 -> I14+i7_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i16 :: I7 -> I16+i7_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i24 :: I7 -> I24+i7_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i32 :: I7 -> I32+i7_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i7_to_i64 :: I7 -> I64+i7_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u4 :: I8 -> U4+i8_to_u4 x = if x < 0 || x > 15 then error "i8_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u7 :: I8 -> U7+i8_to_u7 x = if x < 0 || x > 127 then error "i8_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u8 :: I8 -> U8+i8_to_u8 x = if x < 0 then error "i8_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u12 :: I8 -> U12+i8_to_u12 x = if x < 0 then error "i8_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u14 :: I8 -> U14+i8_to_u14 x = if x < 0 then error "i8_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u16 :: I8 -> U16+i8_to_u16 x = if x < 0 then error "i8_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u24 :: I8 -> U24+i8_to_u24 x = if x < 0 then error "i8_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u32 :: I8 -> U32+i8_to_u32 x = if x < 0 then error "i8_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_u64 :: I8 -> U64+i8_to_u64 x = if x < 0 then error "i8_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_i4 :: I8 -> I4+i8_to_i4 x = if x < -8 || x > 7 then error "i8_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i8_to_i7 :: I8 -> I7+i8_to_i7 x = if x < -64 || x > 63 then error "i8_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i8_to_i12 :: I8 -> I12+i8_to_i12 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i14 :: I8 -> I14+i8_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i16 :: I8 -> I16+i8_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i24 :: I8 -> I24+i8_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i32 :: I8 -> I32+i8_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i8_to_i64 :: I8 -> I64+i8_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u4 :: I12 -> U4+i12_to_u4 x = if x < 0 || x > 15 then error "i12_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u7 :: I12 -> U7+i12_to_u7 x = if x < 0 || x > 127 then error "i12_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u8 :: I12 -> U8+i12_to_u8 x = if x < 0 || x > 255 then error "i12_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u12 :: I12 -> U12+i12_to_u12 x = if x < 0 then error "i12_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u14 :: I12 -> U14+i12_to_u14 x = if x < 0 then error "i12_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u16 :: I12 -> U16+i12_to_u16 x = if x < 0 then error "i12_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u24 :: I12 -> U24+i12_to_u24 x = if x < 0 then error "i12_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u32 :: I12 -> U32+i12_to_u32 x = if x < 0 then error "i12_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_u64 :: I12 -> U64+i12_to_u64 x = if x < 0 then error "i12_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_i4 :: I12 -> I4+i12_to_i4 x = if x < -8 || x > 7 then error "i12_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_i7 :: I12 -> I7+i12_to_i7 x = if x < -64 || x > 63 then error "i12_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i12_to_i8 :: I12 -> I8+i12_to_i8 x = if x < -128 || x > 127 then error "i12_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i12_to_i14 :: I12 -> I14+i12_to_i14 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i16 :: I12 -> I16+i12_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i24 :: I12 -> I24+i12_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i32 :: I12 -> I32+i12_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i12_to_i64 :: I12 -> I64+i12_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u4 :: I14 -> U4+i14_to_u4 x = if x < 0 || x > 15 then error "i14_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u7 :: I14 -> U7+i14_to_u7 x = if x < 0 || x > 127 then error "i14_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u8 :: I14 -> U8+i14_to_u8 x = if x < 0 || x > 255 then error "i14_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u12 :: I14 -> U12+i14_to_u12 x = if x < 0 || x > 4095 then error "i14_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u14 :: I14 -> U14+i14_to_u14 x = if x < 0 then error "i14_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u16 :: I14 -> U16+i14_to_u16 x = if x < 0 then error "i14_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u24 :: I14 -> U24+i14_to_u24 x = if x < 0 then error "i14_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u32 :: I14 -> U32+i14_to_u32 x = if x < 0 then error "i14_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_u64 :: I14 -> U64+i14_to_u64 x = if x < 0 then error "i14_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i4 :: I14 -> I4+i14_to_i4 x = if x < -8 || x > 7 then error "i14_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i7 :: I14 -> I7+i14_to_i7 x = if x < -64 || x > 63 then error "i14_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i8 :: I14 -> I8+i14_to_i8 x = if x < -128 || x > 127 then error "i14_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i14_to_i12 :: I14 -> I12+i14_to_i12 x = if x < -2048 || x > 2047 then error "i14_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i14_to_i16 :: I14 -> I16+i14_to_i16 = fromIntegral++-- | Type specialised 'fromIntegral'+i14_to_i24 :: I14 -> I24+i14_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i14_to_i32 :: I14 -> I32+i14_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i14_to_i64 :: I14 -> I64+i14_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u4 :: I16 -> U4+i16_to_u4 x = if x < 0 || x > 15 then error "i16_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u7 :: I16 -> U7+i16_to_u7 x = if x < 0 || x > 127 then error "i16_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u8 :: I16 -> U8+i16_to_u8 x = if x < 0 || x > 255 then error "i16_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u12 :: I16 -> U12+i16_to_u12 x = if x < 0 || x > 4095 then error "i16_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u14 :: I16 -> U14+i16_to_u14 x = if x < 0 || x > 16383 then error "i16_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u16 :: I16 -> U16+i16_to_u16 x = if x < 0 then error "i16_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u24 :: I16 -> U24+i16_to_u24 x = if x < 0 then error "i16_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u32 :: I16 -> U32+i16_to_u32 x = if x < 0 then error "i16_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_u64 :: I16 -> U64+i16_to_u64 x = if x < 0 then error "i16_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i4 :: I16 -> I4+i16_to_i4 x = if x < -8 || x > 7 then error "i16_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i7 :: I16 -> I7+i16_to_i7 x = if x < -64 || x > 63 then error "i16_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i8 :: I16 -> I8+i16_to_i8 x = if x < -128 || x > 127 then error "i16_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i12 :: I16 -> I12+i16_to_i12 x = if x < -2048 || x > 2047 then error "i16_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i16_to_i14 :: I16 -> I14+i16_to_i14 x = if x < -8192 || x > 8191 then error "i16_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i16_to_i24 :: I16 -> I24+i16_to_i24 = fromIntegral++-- | Type specialised 'fromIntegral'+i16_to_i32 :: I16 -> I32+i16_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i16_to_i64 :: I16 -> I64+i16_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u4 :: I24 -> U4+i24_to_u4 x = if x < 0 || x > 15 then error "i24_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u7 :: I24 -> U7+i24_to_u7 x = if x < 0 || x > 127 then error "i24_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u8 :: I24 -> U8+i24_to_u8 x = if x < 0 || x > 255 then error "i24_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u12 :: I24 -> U12+i24_to_u12 x = if x < 0 || x > 4095 then error "i24_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u14 :: I24 -> U14+i24_to_u14 x = if x < 0 || x > 16383 then error "i24_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u16 :: I24 -> U16+i24_to_u16 x = if x < 0 || x > 65535 then error "i24_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u24 :: I24 -> U24+i24_to_u24 x = if x < 0 then error "i24_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u32 :: I24 -> U32+i24_to_u32 x = if x < 0 then error "i24_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_u64 :: I24 -> U64+i24_to_u64 x = if x < 0 then error "i24_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i4 :: I24 -> I4+i24_to_i4 x = if x < -8 || x > 7 then error "i24_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i7 :: I24 -> I7+i24_to_i7 x = if x < -64 || x > 63 then error "i24_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i8 :: I24 -> I8+i24_to_i8 x = if x < -128 || x > 127 then error "i24_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i12 :: I24 -> I12+i24_to_i12 x = if x < -2048 || x > 2047 then error "i24_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i14 :: I24 -> I14+i24_to_i14 x = if x < -8192 || x > 8191 then error "i24_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i24_to_i16 :: I24 -> I16+i24_to_i16 x = if x < -32768 || x > 32767 then error "i24_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i24_to_i32 :: I24 -> I32+i24_to_i32 = fromIntegral++-- | Type specialised 'fromIntegral'+i24_to_i64 :: I24 -> I64+i24_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u4 :: I32 -> U4+i32_to_u4 x = if x < 0 || x > 15 then error "i32_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u7 :: I32 -> U7+i32_to_u7 x = if x < 0 || x > 127 then error "i32_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u8 :: I32 -> U8+i32_to_u8 x = if x < 0 || x > 255 then error "i32_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u12 :: I32 -> U12+i32_to_u12 x = if x < 0 || x > 4095 then error "i32_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u14 :: I32 -> U14+i32_to_u14 x = if x < 0 || x > 16383 then error "i32_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u16 :: I32 -> U16+i32_to_u16 x = if x < 0 || x > 65535 then error "i32_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u24 :: I32 -> U24+i32_to_u24 x = if x < 0 || x > 16777215 then error "i32_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u32 :: I32 -> U32+i32_to_u32 x = if x < 0 then error "i32_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_u64 :: I32 -> U64+i32_to_u64 x = if x < 0 then error "i32_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i4 :: I32 -> I4+i32_to_i4 x = if x < -8 || x > 7 then error "i32_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i7 :: I32 -> I7+i32_to_i7 x = if x < -64 || x > 63 then error "i32_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i8 :: I32 -> I8+i32_to_i8 x = if x < -128 || x > 127 then error "i32_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i12 :: I32 -> I12+i32_to_i12 x = if x < -2048 || x > 2047 then error "i32_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i14 :: I32 -> I14+i32_to_i14 x = if x < -8192 || x > 8191 then error "i32_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i16 :: I32 -> I16+i32_to_i16 x = if x < -32768 || x > 32767 then error "i32_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i32_to_i24 :: I32 -> I24+i32_to_i24 x = if x < -8388608 || x > 8388607 then error "i32_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral'+i32_to_i64 :: I32 -> I64+i32_to_i64 = fromIntegral++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u4 :: I64 -> U4+i64_to_u4 x = if x < 0 || x > 15 then error "i64_to_u4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u7 :: I64 -> U7+i64_to_u7 x = if x < 0 || x > 127 then error "i64_to_u7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u8 :: I64 -> U8+i64_to_u8 x = if x < 0 || x > 255 then error "i64_to_u8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u12 :: I64 -> U12+i64_to_u12 x = if x < 0 || x > 4095 then error "i64_to_u12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u14 :: I64 -> U14+i64_to_u14 x = if x < 0 || x > 16383 then error "i64_to_u14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u16 :: I64 -> U16+i64_to_u16 x = if x < 0 || x > 65535 then error "i64_to_u16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u24 :: I64 -> U24+i64_to_u24 x = if x < 0 || x > 16777215 then error "i64_to_u24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u32 :: I64 -> U32+i64_to_u32 x = if x < 0 || x > 4294967295 then error "i64_to_u32: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_u64 :: I64 -> U64+i64_to_u64 x = if x < 0 then error "i64_to_u64: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i4 :: I64 -> I4+i64_to_i4 x = if x < -8 || x > 7 then error "i64_to_i4: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i7 :: I64 -> I7+i64_to_i7 x = if x < -64 || x > 63 then error "i64_to_i7: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i8 :: I64 -> I8+i64_to_i8 x = if x < -128 || x > 127 then error "i64_to_i8: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i12 :: I64 -> I12+i64_to_i12 x = if x < -2048 || x > 2047 then error "i64_to_i12: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i14 :: I64 -> I14+i64_to_i14 x = if x < -8192 || x > 8191 then error "i64_to_i14: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i16 :: I64 -> I16+i64_to_i16 x = if x < -32768 || x > 32767 then error "i64_to_i16: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i24 :: I64 -> I24+i64_to_i24 x = if x < -8388608 || x > 8388607 then error "i64_to_i24: OUT-OF-RANGE" else fromIntegral x++-- | Type specialised 'fromIntegral' with out-of-range error.+i64_to_i32 :: I64 -> I32+i64_to_i32 x = if x < -2147483648 || x > 2147483647 then error "i64_to_i32: OUT-OF-RANGE" else fromIntegral x
Music/Theory/Math/Nichomachus.hs view
@@ -42,7 +42,7 @@ > 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+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 @@ -50,4 +50,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+subcont_geometric_mean a c = (a - c + sqrt (a * a - 2 * a * c + 5 * c * c)) / 2
− Music/Theory/Math/OEIS.hs 
@@ -1,470 +0,0 @@--- | The On-Line Encyclopedia of Integer Sequences, <http://oeis.org/>-module Music.Theory.Math.OEIS where--import Data.List {- base -}-import Data.Ratio {- base -}--import qualified Music.Theory.Math as Math {- hmt -}--{- | <http://oeis.org/A000010>--Euler totient function phi(n): count numbers <= n and prime to n.--> [1,1,2,2,4,2,6,4,6,4,10,4,12,6,8,8,16,6,18,8,12,10,22,8,20,12] `isPrefixOf` a000010--}-a000010 :: Integral n => [n]-a000010 =-  let phi n = genericLength (filter (==1) (map (gcd n) [1..n]))-  in map phi [1::Integer ..]--{- | <http://oeis.org/A000045>--Fibonacci numbers--> [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610] `isPrefixOf` a000045--}-a000045 :: Num n => [n]-a000045 = 0 : 1 : zipWith (+) a000045 (tail a000045)--{- | <http://oeis.org/A000051>--a(n) = 2^n + 1--> [2,3,5,9,17,33,65,129,257,513,1025,2049,4097,8193,16385,32769,65537,131073] `isPrefixOf` a000051--}-a000051 :: Num n => [n]-a000051 = iterate ((subtract 1) . (* 2)) 2--{- | <http://oeis.org/A000079>--Powers of 2: a(n) = 2^n--> [1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768,65536] `isPrefixOf` a000079--}-a000079 :: Num n => [n]-a000079 = iterate (* 2) 1--{- | <http://oeis.org/A000142>--Factorial numbers: n! = 1*2*3*4*...*n-(order of symmetric group S_n, number of permutations of n letters).--> [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800,479001600,6227020800] `isPrefixOf` a000142--}-a000142 :: (Enum n, Num n) => [n]-a000142 = 1 : zipWith (*) [1..] a000142--{- | https://oeis.org/A000201--Lower Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi), where phi = (1+sqrt(5))/2 = A001622--> [1,3,4,6,8,9,11,12,14,16,17,19,21,22,24,25,27,29,30,32,33,35,37,38,40,42] `isPrefixOf` a000201--> import Sound.SC3.Plot {- hsc3-plot -}-> plot_p1_imp [take 128 a000201 :: [Int]]--}-a000201 :: Integral n => [n]-a000201 =-  let f (x:xs) (y:ys) = y : f xs (delete (x + y) ys)-      f _ _ = error "a000201"-  in f [1..] [1..]--{- | <https://oeis.org/A000204>--Lucas numbers (beginning with 1): L(n) = L(n-1) + L(n-2) with L(1) = 1, L(2) = 3--> [1,3,4,7,11,18,29,47,76,123,199,322,521,843,1364,2207,3571,5778,9349,15127] `isPrefixOf` a000204--}-a000204 :: Num n => [n]-a000204 = 1 : 3 : zipWith (+) a000204 (tail a000204)--{- | <https://oeis.org/A000217>--Triangular numbers: a(n) = binomial(n+1,2) = n(n+1)/2 = 0 + 1 + 2 + ... + n.--> [0,1,3,6,10,15,21,28,36,45,55,66,78,91,105,120,136,153,171,190,210,231,253,276] `isPrefixOf` a000217--}-a000217 :: (Enum n,Num n) => [n]-a000217 = scanl1 (+) [0..]--{- | <http://oeis.org/A000225>--a(n) = 2^n - 1 (Sometimes called Mersenne numbers, although that name is usually reserved for A001348)--> [0,1,3,7,15,31,63,127,255,511,1023,2047,4095,8191,16383,32767,65535] `isPrefixOf` a000225--}-a000225 :: Num n => [n]-a000225 = iterate ((+ 1) . (* 2)) 0--{- | <http://oeis.org/A000290>--The squares of the non-negative integers.--> [0,1,4,9,16,25,36,49,64,81,100] `isPrefixOf` a000290--}-a000290 :: Integral n => [n]-a000290 = let square n = n * n in map square [0..]--{- | <https://oeis.org/A000292>--Tetrahedral (or triangular pyramidal) numbers: a(n) = C(n+2,3) = n*(n+1)*(n+2)/6.--> [0,1,4,10,20,35,56,84,120,165,220,286,364,455,560,680,816,969,1140,1330,1540] `isPrefixOf` a000292--}-a000292 :: (Enum n,Num n) => [n]-a000292 = scanl1 (+) a000217--{- | <https://oeis.org/A000930>--Narayana's cows sequence.--> [1,1,1,2,3,4,6,9,13,19,28,41,60] `isPrefixOf` a000930--}-a000930 :: Num n => [n]-a000930 = 1 : 1 : 1 : zipWith (+) a000930 (drop 2 a000930)--{- | <https://oeis.org/A000931>--Padovan sequence (or Padovan numbers)--> [1,0,0,1,0,1,1,1,2,2,3,4,5,7,9,12,16,21,28,37,49,65,86,114,151,200,265] `isPrefixOf` a000931--}-a000931 :: Num n => [n]-a000931 = 1 : 0 : 0 : zipWith (+) a000931 (tail a000931)--{- | <https://oeis.org/A001008>--Numerators of harmonic numbers H(n) = Sum_{i=1..n} 1/i--[1,3,11,25,137,49,363,761,7129,7381,83711,86021,1145993,1171733,1195757,2436559] `isPrefixOf` a001008--}-a001008 :: Integral i => [i]-a001008 = map numerator (scanl1 (+) (map (1 %) [1..]))--{- | <https://oeis.org/A001333>--Numerators of continued fraction convergents to sqrt(2).--[1,1,3,7,17,41,99,239,577,1393,3363,8119,19601,47321,114243,275807,665857] `isPrefixOf` a001333--}-a001333 :: Num n => [n]-a001333 = 1 : 1 : zipWith (+) a001333 (map (* 2) (tail a001333))--{- | <http://oeis.org/A001687>--a(n) = a(n-2) + a(n-5).--[0,1,0,1,0,1,1,1,2,1,3,2,4,4,5,7,7,11,11,16,18,23,29,34,45,52,68,81,102,126,154] `isPrefixOf` a001687--}-a001687 :: Num n => [n]-a001687 = 0 : 1 : 0 : 1 : 0 : zipWith (+) a001687 (drop 3 a001687)--{- | <https://oeis.org/A001950>--Upper Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi^2), where phi = (1+sqrt(5))/2--> [2,5,7,10,13,15,18,20,23,26,28,31,34,36,39,41,44,47,49,52,54,57,60,62,65] `isPrefixOf` a001950--}-a001950 :: Integral n => [n]-a001950 = zipWith (+) a000201 [1..]---- | <http://oeis.org/A002267>------ The 15 supersingular primes.-a002267 :: Num n => [n]-a002267 = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 41, 47, 59, 71]--{- | <https://oeis.org/A002487>--Stern's diatomic series (or Stern-Brocot sequence)--> [0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5] `isPrefixOf` a002487--}-a002487 :: Num n => [n]-a002487 =-  let f (a:a') (b:b') = a + b : a : f a' b'-      f _ _ = error "a002487?"-      x = 1 : 1 : f (tail x) x-  in 0 : x---- | <http://oeis.org/A003269>------ [0,1,1,1,1,2,3,4,5,7,10,14,19,26,36,50,69,95,131,181,250,345,476,657] `isPrefixOf` a003269-a003269 :: Num n => [n]-a003269 = 0 : 1 : 1 : 1 : zipWith (+) a003269 (drop 3 a003269)--{- | <http://oeis.org/A003520>--a(n) = a(n-1) + a(n-5); a(0) = ... = a(4) = 1.--> [1,1,1,1,1,2,3,4,5,6,8,11,15,20,26,34,45,60,80,106,140,185,245,325,431] `isPrefixOf` a003520--}-a003520 :: Num n => [n]-a003520 = 1 : 1 : 1 : 1 : 1 : zipWith (+) a003520 (drop 4 a003520)--{- | <https://oeis.org/A003849>--The infinite Fibonacci word (start with 0, apply 0->01, 1->0, take limit).--> [0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0] `isPrefixOf` a003849--}-a003849 :: Num n => [n]-a003849 =-  let fws = [1] : [0] : zipWith (++) fws (tail fws)-  in tail (concat fws)--{- | <http://oeis.org/A004718>--Per Nørgård's "infinity sequence"--> take 32 a004718 == [0,1,-1,2,1,0,-2,3,-1,2,0,1,2,-1,-3,4,1,0,-2,3,0,1,-1,2,-2,3,1,0,3,-2,-4,5]--> plot_p1_imp [take 1024 a004718]--<https://www.tandfonline.com/doi/abs/10.1080/17459737.2017.1299807>-<https://arxiv.org/pdf/1402.3091.pdf>---}-a004718 :: Num n => [n]-a004718 = 0 : concat (transpose [map (+ 1) a004718, map negate (tail a004718)])--{- | <http://oeis.org/A005728>--Number of fractions in Farey series of order n.--> [1,2,3,5,7,11,13,19,23,29,33,43,47,59,65,73,81,97,103,121,129,141,151] `isPrefixOf` a005728--}-a005728 :: Integral i => [i]-a005728 =-  let phi n = genericLength (filter (==1) (map (gcd n) [1..n]))-      f n = if n == 0 then 1 else f (n - 1) + phi n-  in map f [0::Integer ..]--{- | <http://oeis.org/A005811>--Number of runs in binary expansion of n (n>0); number of 1's in Gray code for n--> take 32 a005811 == [0,1,2,1,2,3,2,1,2,3,4,3,2,3,2,1,2,3,4,3,4,5,4,3,2,3,4,3,2,3,2,1]--}-a005811 :: Integral n => [n]-a005811 =-  let f (x:xs) = x : f (xs ++ [x + x `mod` 2, x + 1 - x `mod` 2])-      f _ = error "A005811?"-  in 0 : f [1]--{- | <http://oeis.org/A006842>--Triangle read by rows: row n gives numerators of Farey series of order n.--> [0,1,0,1,1,0,1,1,2,1,0,1,1,1,2,3,1,0,1,1,1,2,1,3,2,3,4,1,0,1,1,1,1,2,1,3] `isPrefixOf` a006842-> plot_p1_imp [take 200 (a006842 :: [Int])]-> plot_p1_pt [take 10000 (a006842 :: [Int])]--}-a006842 :: Integral i => [i]-a006842 = map numerator (concatMap Math.farey [1..])--{- | <http://oeis.org/A006843>--Triangle read by rows: row n gives denominators of Farey series of order n--> [1,1,1,2,1,1,3,2,3,1,1,4,3,2,3,4,1,1,5,4,3,5,2,5,3,4,5,1,1,6,5,4,3,5,2,5] `isPrefixOf` a006843-> plot_p1_imp [take 200 (a006843 :: [Int])]-> plot_p1_pt [take 10000 (a006843 :: [Int])]--}-a006843 :: Integral i => [i]-a006843 = map denominator (concatMap Math.farey [1..])--{- | <https://oeis.org/A007318>--Pascal's triangle read by rows--[[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1],[1,5,10,10,5,1]] `isPrefixOf` a007318--}-a007318 :: Integral i => [[i]]-a007318 =-  let f r = zipWith (+) ([0] ++ r) (r ++ [0])-  in iterate f [1]--{- | <https://oeis.org/A008277>--Triangle of Stirling numbers of the second kind, S2(n,k), n >= 1, 1 <= k <= n.--[1,1,1,1,3,1,1,7,6,1,1,15,25,10,1,1,31,90,65,15,1,1,63,301,350,140,21,1] `isPrefixOf` a008277--}-a008277 :: (Enum n,Num n) => [n]-a008277 = concat a008277_tbl--a008277_tbl :: (Enum n,Num n) => [[n]]-a008277_tbl = map tail $ a048993_tbl--{- | <http://oeis.org/A008278>--Triangle of Stirling numbers of 2nd kind, S(n,n-k+1), n >= 1, 1<=k<=n.--[1,1,1,1,3,1,1,6,7,1,1,10,25,15,1,1,15,65,90,31,1,1,21,140,350,301,63,1] `isPrefixOf` a008278--}-a008278 :: (Enum n,Num n) => [n]-a008278 = concat a008278_tbl--a008278_tbl :: (Enum n,Num n) => [[n]]-a008278_tbl =-  let f p =-        let q = reverse (zipWith (*) [1..] (reverse p))-        in zipWith (+) ([0] ++ q) (p ++ [0])-  in iterate f [1]--{- | <http://oeis.org/A017817>--a(n) = a(n-3) + a(n-4), with a(0)=1, a(1)=a(2)=0, a(3)=1--> [1,0,0,1,1,0,1,2,1,1,3,3,2,4,6,5,6,10,11,11,16,21,22,27,37,43,49,64,80,92] `isPrefixOf` a017817--}-a017817 :: Num n => [n]-a017817 = 1 : 0 : 0 : 1 : zipWith (+) a017817 (tail a017817)---{- | <http://oeis.org/A030308>--Triangle T(n,k): Write n in base 2, reverse order of digits, to get the n-th row--> take 9 a030308 == [[0],[1],[0,1],[1,1],[0,0,1],[1,0,1],[0,1,1],[1,1,1],[0,0,0,1]]--}-a030308 :: (Eq n,Num n) => [[n]]-a030308 =-   let f l = case l of-         [] -> [1]-         0:b -> 1 : b-         1:b -> 0 : f b-         _ -> error "A030308?"-   in iterate f [0]--{- | <https://oeis.org/A048993>--Triangle of Stirling numbers of 2nd kind, S(n,k), n >= 0, 0 <= k <= n.--> [1,0,1,0,1,1,0,1,3,1,0,1,7,6,1,0,1,15,25,10,1,0,1,31,90,65,15,1] `isPrefixOf` a048993--}-a048993 :: (Enum n,Num n) => [n]-a048993 = concat a048993_tbl--a048993_tbl :: (Enum n,Num n) => [[n]]-a048993_tbl = iterate (\row -> [0] ++ (zipWith (+) row $ zipWith (*) [1..] $ tail row) ++ [1]) [1]--{- | <http://oeis.org/A049455>--Triangle read by rows, numerator of fractions of a variant of the Farey series.--> [0,1,0,1,1,0,1,1,2,1,0,1,1,2,1,3,2,3,1,0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,0] `isPrefixOf` a049455-> plot_p1_imp [take 200 (a049455 :: [Int])]-> plot_p1_pt [take 10000 (a049455 :: [Int])]--}-a049455 :: Integral n => [n]-a049455 = map fst (concat Math.stern_brocot_tree_lhs)--{- | <http://oeis.org/A049456>--Triangle read by rows, denominator of fractions of a variant of the Farey series.--[1,1,1,2,1,1,3,2,3,1,1,4,3,5,2,5,3,4,1,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5,1,1,6,5,9] `isPrefixOf` a049456-> plot_p1_imp [take 200 (a049456 :: [Int])]-> plot_p1_pt [take 10000 (a049456 :: [Int])]--}-a049456 :: Integral n => [n]-a049456 = map snd (concat Math.stern_brocot_tree_lhs)--{- | <http://oeis.org/A073334>--The "rhythmic infinity system" of Danish composer Per Nørgård--> take 24 a073334 == [3,5,8,5,8,13,8,5,8,13,21,13,8,13,8,5,8,13,21,13,21,34,21,13]-> plot_p1_imp [take 200 (a073334 :: [Int])]--}-a073334 :: Num n => [n]-a073334 =-  let f n = a000045 !! ((a005811 !! n) + 4)-  in 3 : map f [1..]---- | <http://oeis.org/A080992>------ Entries in Durer's magic square.-a080992 :: Num n => [n]-a080992 =-  [16,03,02,13-  ,05,10,11,08-  ,09,06,07,12-  ,04,15,14,01]--{- | <http://oeis.org/A083866>--Positions of zeros in Per Nørgård's infinity sequence (A004718).--> take 24 a083866 == [0,5,10,17,20,27,34,40,45,54,65,68,75,80,85,90,99,105,108,119,130,136,141,150]--}-a083866 :: (Enum n,Num n) => [n]-a083866 = map snd (filter ((== (0::Int)) . fst) (zip a004718 [0..]))---- | <http://oeis.org/A126709>------ Loh-Shu magic square, attributed to the legendary Fu Xi (Fuh-Hi).-a126709 :: Num n => [n]-a126709 =-  [4,9,2-  ,3,5,7-  ,8,1,6]---- | <http://oeis.org/A126710>------ Jaina inscription of the twelfth or thirteenth century, Khajuraho, India.-a126710 :: Num n => [n]-a126710 =-  [07,12,01,14-  ,02,13,08,11-  ,16,03,10,05-  ,09,06,15,04]---- | <http://oeis.org/A126976>------ Agrippa (Magic Square of the Sun)-a126976 :: Num n => [n]-a126976 =-  [06,32,03,34,35,01-  ,07,11,27,28,08,30-  ,19,14,16,15,23,24-  ,18,20,22,21,17,13-  ,25,29,10,09,26,12-  ,36,05,33,04,02,31]--{- | <http://oeis.org/A255723>--Another variant of Per Nørgård's "infinity sequence"--> take 24 a255723 == [0,-2,-1,2,-2,-4,1,0,-1,-3,0,1,2,0,-3,4,-2,-4,1,0,-4,-6,3,-2]-> plot_p1_imp [take 400 (a255723 :: [Int])]--}-a255723 :: Num n => [n]-a255723 = 0 : concat (transpose [map (subtract 2) a255723-                                ,map (-1 -) a255723-                                ,map (+ 2) a255723-                                ,tail a255723])--{- | <http://oeis.org/A256184>--First of two variations by Per Nørgård of his "infinity sequence"--> take 24 a256184 == [0,-2,-1,2,-4,-3,1,-3,-2,-2,0,1,4,-6,-5,3,-5,-4,-1,-1,0,3,-5,-4]--}-a256184 :: Num n => [n]-a256184 = 0 : concat (transpose [map (subtract 2) a256184-                                ,map (subtract 1) a256184-                                ,map negate (tail a256184)])--{- | <http://oeis.org/A256185>--Second of two variations by Per Nørgård of his "infinity sequence"--> take 24 a256185 == [0,-3,-2,3,-6,1,2,-5,0,-3,0,-5,6,-9,4,-1,-2,-3,-2,-1,-4,5,-8,3]--}-a256185 :: Num n => [n]-a256185 = 0 : concat (transpose [map (subtract 3) a256185-                                ,map (-2 -) a256185-                                ,map negate (tail a256185)])
+ Music/Theory/Math/Oeis.hs view
@@ -0,0 +1,1478 @@+-- | The On-Line Encyclopedia of Integer Sequences, <http://oeis.org/>+module Music.Theory.Math.Oeis where++import Data.Bits {- base -}+import Data.Char {- base -}+import Data.List {- base -}+import Data.Ratio {- base -}++import qualified Data.Set as Set {- containers -}++import qualified Data.MemoCombinators as Memo {- data-memocombinators -}++import qualified Music.Theory.Math as Math {- hmt-base -}++import qualified Music.Theory.Math.Prime as Prime {- hmt -}++{- | <http://oeis.org/A000005>++d(n) (also called tau(n) or sigma_0(n)), the number of divisors of n. (Formerly M0246 N0086)++[1, 2, 2, 3, 2, 4, 2, 4, 3, 4, 2, 6, 2, 4, 4, 5, 2, 6, 2, 6, 4, 4, 2, 8, 3, 4, 4, 6, 2, 8, 2, 6, 4, 4, 4, 9, 2, 4, 4, 8, 2, 8, 2, 6, 6, 4, 2, 10, 3, 6, 4, 6, 2, 8, 4, 8, 4, 4, 2, 12, 2, 4, 6, 7, 4, 8, 2, 6, 4, 8, 2, 12, 2, 4, 6, 6, 4, 8, 2, 10, 5, 4, 2, 12, 4, 4, 4, 8, 2, 12, 4, 6, 4, 4, 4, 12, 2, 6, 6, 9, 2, 8, 2, 8] `isPrefixOf` a000005+-}+a000005 :: Integral n => [n]+a000005 = map (product . map (+ 1) . a124010_row) [1..]++{- | <http://oeis.org/A000010>++Euler totient function phi(n): count numbers <= n and prime to n.++> [1,1,2,2,4,2,6,4,6,4,10,4,12,6,8,8,16,6,18,8,12,10,22,8,20,12] `isPrefixOf` a000010+-}+a000010 :: Integral n => [n]+a000010 = map a000010_n [1 ..]++a000010_n :: Integral n => n -> n+a000010_n n = genericLength (filter (==1) (map (gcd n) [1..n]))++{- | <http://oeis.org/A000012>++The simplest sequence of positive numbers: the all 1's sequence.+-}+a000012 :: Num n => [n]+a000012 = repeat 1++{- | <https://oeis.org/A000031>++Number of n-bead necklaces with 2 colors when turning over is not allowed; also number of output sequences from a simple n-stage cycling shift register; also number of binary irreducible polynomials whose degree divides n.++> [1,2,3,4,6,8,14,20,36,60,108,188,352,632,1182,2192,4116,7712,14602,27596] `isPrefixOf` a000031+-}+a000031 :: Integral n => [n]+a000031 = map a000031_n [0..]++a000031_n :: Integral n => n -> n+a000031_n n =+  if n == 0+  then 1+  else let divs = a027750_row n+       in ((`div` n) . sum . zipWith (*) (map a000010_n divs) . map (2 ^) . reverse) divs++{- | <http://oeis.org/A000032>++Lucas numbers beginning at 2: L(n) = L(n-1) + L(n-2), L(0) = 2, L(1) = 1. (Formerly M0155)++> [2,1,3,4,7,11,18,29,47,76,123,199,322,521,843,1364,2207,3571,5778,9349,15127] `isPrefixOf` a000032+-}+a000032 :: Num n => [n]+a000032 = 2 : 1 : zipWith (+) a000032 (tail a000032)++{- | <http://oeis.org/A000040>++The prime numbers.++> [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103] `isPrefixOf` a000040+-}+a000040 :: Integral n => [n]+a000040 =+  let base = [2, 3, 5, 7, 11, 13, 17]+      larger = p0 : filter prime more+      prime n = all ((> 0) . mod n) (takeWhile (\x -> x*x <= n) larger)+      _ : p0 : more = roll (makeWheels base)+      roll (n,rs) = [n * k + r | k <- [0..], r <- rs]+      makeWheels = foldl nextSize (1,[1])+      nextSize (size,bs) p = (size * p,[r | k <- [0..p-1], b <- bs, let r = size*k+b, mod r p > 0])+  in base ++ larger++{- | <http://oeis.org/A000041>++a(n) is the number of partitions of n (the partition numbers).++[1,1,2,3,5,7,11,15,22,30,42,56,77,101,135,176,231,297,385,490,627,792,1002,1255] `isPrefixOf` a000041+-}+a000041 :: Num n => [n]+a000041 =+  let p_m = Memo.memo2 Memo.integral Memo.integral p+      p _ 0 = 1+      p k m = if m < k then 0 else p_m k (m - k) + p_m (k + 1) m+  in map (p_m 1) [0::Integer ..]++{- | <http://oeis.org/A000045>++Fibonacci numbers++> [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181,6765,10946] `isPrefixOf` a000045+-}+a000045 :: Num n => [n]+a000045 = 0 : 1 : zipWith (+) a000045 (tail a000045)++{- | <http://oeis.org/A000051>++a(n) = 2^n + 1++> [2,3,5,9,17,33,65,129,257,513,1025,2049,4097,8193,16385,32769,65537,131073] `isPrefixOf` a000051+-}+a000051 :: Num n => [n]+a000051 = iterate (subtract 1 . (* 2)) 2++{- | <http://oeis.org/A000071>++a(n) = Fibonacci(n) - 1.++> [0,0,1,2,4,7,12,20,33,54,88,143,232,376,609,986,1596,2583,4180,6764,10945,17710] `isPrefixOf` a000071+-}+a000071 :: Num n => [n]+a000071 = map (subtract 1) (tail a000045)++{- | <http://oeis.org/A000073>++Tribonacci numbers: a(n) = a(n-1) + a(n-2) + a(n-3) for n >= 3 with a(0) = a(1) = 0 and a(2) = 1.++> [0,0,1,1,2,4,7,13,24,44,81,149,274,504,927,1705,3136,5768,10609,19513,35890] `isPrefixOf` a000073+-}+a000073 :: Num n => [n]+a000073 = 0 : 0 : 1 : zipWith (+) a000073 (tail (zipWith (+) a000073 (tail a000073)))++{- | <http://oeis.org/A000078>++Tetranacci numbers: a(n) = a(n-1) + a(n-2) + a(n-3) + a(n-4) with a(0)=a(1)=a(2)=0, a(3)=1.++> [0,0,0,1,1,2,4,8,15,29,56,108,208,401,773,1490,2872,5536,10671,20569,39648] `isPrefixOf` a000078+-}+a000078 :: Num n => [n]+a000078 =+  let f xs = let y = (sum . head . transpose . take 4 . tails) xs in y : f (y:xs)+  in 0 : 0 : 0 : f [0, 0, 0, 1]++{- | <http://oeis.org/A000079>++Powers of 2: a(n) = 2^n. (Formerly M1129 N0432)++> [1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768,65536] `isPrefixOf` a000079+> [1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768,65536] `isPrefixOf` map (2 ^) [0..]+-}+a000079 :: Num n => [n]+a000079 = iterate (* 2) 1++{- | <http://oeis.org/A000085>++Number of self-inverse permutations on n letters, also known as involutions; number of standard Young tableaux with n cells.++> [1,1,2,4,10,26,76,232,764,2620,9496,35696,140152,568504,2390480,10349536] `isPrefixOf` a000085+-}+a000085 :: Integral n => [n]+a000085 = 1 : 1 : zipWith (+) (zipWith (*) [1..] a000085) (tail a000085)++{- | <http://oeis.org/A000108>++Catalan numbers: C(n) = binomial(2n,n)/(n+1) = (2n)!/(n!(n+1)!).++> [1,1,2,5,14,42,132,429,1430,4862,16796,58786,208012,742900,2674440,9694845] `isPrefixOf` a000108+-}+a000108 :: Num n => [n]+a000108 = map last (iterate (scanl1 (+) . (++ [0])) [1])++{- | <http://oeis.org/A000120>++1's-counting sequence: number of 1's in binary expansion of n (or the binary weight of n).++> [0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,1,2,2,3,2,3,3] `isPrefixOf` a000120+-}+a000120 :: Integral i => [i]+a000120 = let r = [0] : (map . map) (+ 1) (scanl1 (++) r) in concat r++{- | <http://oeis.org/A000142>++Factorial numbers: n! = 1*2*3*4*...*n+(order of symmetric group S_n, number of permutations of n letters).++> [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800,479001600,6227020800] `isPrefixOf` a000142+-}+a000142 :: (Enum n, Num n) => [n]+a000142 = 1 : zipWith (*) [1..] a000142++{- | https://oeis.org/A000201++Lower Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi), where phi = (1+sqrt(5))/2 = A001622++> [1,3,4,6,8,9,11,12,14,16,17,19,21,22,24,25,27,29,30,32,33,35,37,38,40,42] `isPrefixOf` a000201++> import Sound.SC3.Plot {- hsc3-plot -}+> plot_p1_imp [take 128 a000201 :: [Int]]+-}+a000201 :: Integral n => [n]+a000201 =+  let f (x:xs) (y:ys) = y : f xs (delete (x + y) ys)+      f _ _ = error "a000201"+  in f [1..] [1..]++{- | <https://oeis.org/A000204>++Lucas numbers (beginning with 1): L(n) = L(n-1) + L(n-2) with L(1) = 1, L(2) = 3++> [1,3,4,7,11,18,29,47,76,123,199,322,521,843,1364,2207,3571,5778,9349,15127] `isPrefixOf` a000204+-}+a000204 :: Num n => [n]+a000204 = 1 : 3 : zipWith (+) a000204 (tail a000204)++{- | <http://oeis.org/A000213>++Tribonacci numbers: a(n) = a(n-1) + a(n-2) + a(n-3) with a(0)=a(1)=a(2)=1.++[1,1,1,3,5,9,17,31,57,105,193,355,653,1201,2209,4063,7473,13745,25281,46499]  `isPrefixOf` a000213+-}+a000213 :: Num n => [n]+a000213 = 1 : 1 : 1 : zipWith (+) a000213 (tail (zipWith (+) a000213 (tail a000213)))++{- | <https://oeis.org/A000217>++Triangular numbers: a(n) = binomial(n+1,2) = n(n+1)/2 = 0 + 1 + 2 + ... + n.++> [0,1,3,6,10,15,21,28,36,45,55,66,78,91,105,120,136,153,171,190,210,231,253,276] `isPrefixOf` a000217+-}+a000217 :: (Enum n,Num n) => [n]+a000217 = scanl1 (+) [0..]++{- | <http://oeis.org/A000225>++a(n) = 2^n - 1 (Sometimes called Mersenne numbers, although that name is usually reserved for A001348)++> [0,1,3,7,15,31,63,127,255,511,1023,2047,4095,8191,16383,32767,65535] `isPrefixOf` a000225+-}+a000225 :: Num n => [n]+a000225 = iterate ((+ 1) . (* 2)) 0++{- | <http://oeis.org/000285>++a(0) = 1, a(1) = 4, and a(n) = a(n-1) + a(n-2) for n >= 2. (Formerly M3246 N1309)++> [1,4,5,9,14,23,37,60,97,157,254,411,665,1076,1741,2817,4558,7375,11933,19308] `isPrefixOf` a000285+-}+a000285 :: Num n => [n]+a000285 = 1 : 4 : zipWith (+) a000285 (tail a000285)++{- | <http://oeis.org/A000290>++The squares of the non-negative integers.++> [0,1,4,9,16,25,36,49,64,81,100] `isPrefixOf` a000290+-}+a000290 :: Integral n => [n]+a000290 = let square n = n * n in map square [0..]++{- | <https://oeis.org/A000292>++Tetrahedral (or triangular pyramidal) numbers: a(n) = C(n+2,3) = n*(n+1)*(n+2)/6.++> [0,1,4,10,20,35,56,84,120,165,220,286,364,455,560,680,816,969,1140,1330,1540] `isPrefixOf` a000292+-}+a000292 :: (Enum n,Num n) => [n]+a000292 = scanl1 (+) a000217++{- | <http://oeis.org/A000384>++Hexagonal numbers: a(n) = n*(2*n-1). (Formerly M4108 N1705)++> [0,1,6,15,28,45,66,91,120,153,190,231,276,325,378,435,496,561,630,703,780,861] `isPrefixOf` a000384+-}+a000384 :: Integral n => [n]+a000384 = scanl (+) 0 a016813++{- | <http://oeis.org/A000578>++The cubes: a(n) = n^3.++> [0,1,8,27,64,125,216,343,512,729,1000,1331,1728,2197,2744,3375,4096,4913,5832] `isPrefixOf` a000578+-}+a000578 :: Num n => [n]+a000578 =+  0 : 1 : 8 :+  zipWith (+) (map (+ 6) a000578) (map (* 3) (tail (zipWith (-) (tail a000578) a000578)))++{- | <http://oeis.org/A000583>++Fourth powers: a(n) = n^4.++> [0,1,16,81,256,625,1296,2401,4096,6561,10000,14641,20736,28561,38416,50625] `isPrefixOf` a000583+-}+a000583 :: Integral n => [n]+a000583 = scanl (+) 0 a005917++{- | <http://oeis.org/A000670>++Fubini numbers: number of preferential arrangements of n labeled elements; or number of weak orders on n labeled elements; or number of ordered partitions of [n].++> [1,1,3,13,75,541,4683,47293,545835,7087261,102247563,1622632573,28091567595] `isPrefixOf` a000670+-}+a000670 :: Integral n => [n]+a000670 =+  let f xs (bs:bss) = let y = sum (zipWith (*) xs bs) in y : f (y : xs) bss+      f _ _ = error "a000670d"+  in 1 : f [1] (map tail (tail a007318_tbl))++{- | <https://oeis.org/A000796>++Decimal expansion of Pi (or digits of Pi).++> [3,1,4,1,5,9,2,6,5,3,5,8,9,7,9,3,2,3,8,4,6,2,6,4,3,3,8,3,2,7,9,5,0,2,8,8,4,1,9] `isPrefixOf` a000796++> pi :: Data.Number.Fixed.Fixed Data.Number.Fixed.Prec500 {- numbers -}+-}+a000796 :: Integral n => [n]+a000796 =+  let gen _ [] = error "A000796"+      gen z (x:xs) =+        let lb = approx z 3+            approx (a,b,c) n = div (a * n + b) c+            mult (a,b,c) (d,e,f) = (a * d,a * e + b * f,c * f)+        in if lb /= approx z 4+           then gen (mult z x) xs+        else lb : gen (mult (10,-10 * lb,1) z) (x:xs)+  in map fromInteger (gen (1,0,1) [(n,a*d,d) | (n,d,a) <- map (\k -> (k,2 * k + 1,2)) [1..]])++{- | <https://oeis.org/A000930>++Narayana's cows sequence.++> [1,1,1,2,3,4,6,9,13,19,28,41,60] `isPrefixOf` a000930+-}+a000930 :: Num n => [n]+a000930 = 1 : 1 : 1 : zipWith (+) a000930 (drop 2 a000930)++{- | <https://oeis.org/A000931>++Padovan sequence (or Padovan numbers): a(n) = a(n-2) + a(n-3) with a(0) = 1, a(1) = a(2) = 0.++> [1,0,0,1,0,1,1,1,2,2,3,4,5,7,9,12,16,21,28,37,49,65,86,114,151,200,265] `isPrefixOf` a000931+-}+a000931 :: Num n => [n]+a000931 = 1 : 0 : 0 : zipWith (+) a000931 (tail a000931)++{- | <https://oeis.org/A001008>++Numerators of harmonic numbers H(n) = Sum_{i=1..n} 1/i++[1,3,11,25,137,49,363,761,7129,7381,83711,86021,1145993,1171733,1195757,2436559] `isPrefixOf` a001008+-}+a001008 :: Integral i => [i]+a001008 = map numerator (scanl1 (+) (map (1 %) [1..]))++{- | <http://oeis.org/A001037>++Number of degree-n irreducible polynomials over GF(2); number of+n-bead necklaces with beads of 2 colors when turning over is not+allowed and with primitive period n; number of binary Lyndon words of+length n.++> [1,2,1,2,3,6,9,18,30,56,99,186,335,630,1161,2182,4080,7710,14532,27594,52377,99858,190557,364722,698870] `isPrefixOf` a001037+-}+a001037 :: Integral n => [n]+a001037 = map a001037_n [0..]++a001037_n :: Integral n => n -> n+a001037_n n = if n == 0 then 1 else (sum (map (\d -> (2 ^ d) * a008683_n (n `div` d)) (a027750_row n))) `div` n++{- | <http://oeis.org/A001113>++Decimal expansion of e.++> [2,7,1,8,2,8,1,8,2,8,4,5,9,0,4,5,2,3,5,3,6,0,2,8,7,4,7,1,3,5,2,6,6,2,4,9,7,7,5] `isPrefixOf` a001113++> exp 1 :: Data.Number.Fixed.Fixed Data.Number.Fixed.Prec500 {- numbers -}+-}+a001113 :: Integral n => [n]+a001113 =+  let gen _ [] = error "A001113"+      gen z (x:xs) =+        let lb = approx z 1+            approx (a,b,c) n = div (a * n + b) c+            mult (a,b,c) (d,e,f) = (a * d,a * e + b * f,c * f)+        in if lb /= approx z 2+           then gen (mult z x) xs+           else lb : gen (mult (10,-10 * lb,1) z) (x:xs)+  in gen (1,0,1) [(n,a * d,d) | (n,d,a) <- map (\k -> (1,k,1)) [1..]]++{- | <https://oeis.org/A001147>++Double factorial of odd numbers: a(n) = (2*n-1)!! = 1*3*5*...*(2*n-1). (Formerly M3002 N1217)++> [1,1,3,15,105,945,10395,135135,2027025,34459425,654729075,13749310575] `isPrefixOf` a001147+-}+a001147 :: Integral t => [t]+a001147 = 1 : zipWith (*) [1, 3 ..] a001147++{- | <https://oeis.org/A001156>++Number of partitions of n into squares.++> [1,1,1,1,2,2,2,2,3,4,4,4,5,6,6,6,8,9,10,10,12,13,14,14,16,19,20,21,23,26,27,28] `isPrefixOf` a001156+-}+a001156 :: Num n => [n]+a001156 =+  let p _ 0 = 1+      p ks'@(k:ks) m = if m < k then 0 else p ks' (m - k) + p ks m+      p _ _ = error "A001156"+  in map (p (tail a000290)) [0::Integer ..]++{- | <https://oeis.org/A001333>++Numerators of continued fraction convergents to sqrt(2).++[1,1,3,7,17,41,99,239,577,1393,3363,8119,19601,47321,114243,275807,665857] `isPrefixOf` a001333+-}+a001333 :: Num n => [n]+a001333 = 1 : 1 : zipWith (+) a001333 (map (* 2) (tail a001333))++{- | <http://oeis.org/A001622>++Decimal expansion of golden ratio phi (or tau) = (1 + sqrt(5))/2.++> [1,6,1,8,0,3,3,9,8,8,7,4,9,8,9,4,8,4,8,2,0,4,5,8,6,8,3,4,3,6,5,6,3,8,1,1,7,7,2] `isPrefixOf` a001622++> a001622_k :: Data.Number.Fixed.Fixed Data.Number.Fixed.Prec500 {- numbers -}+-}+a001622 :: Num n => [n]+a001622 = map (fromIntegral . digitToInt) "161803398874989484820458683436563811772030917980576286213544862270526046281890244970720720418939113748475408807538689175212663386222353693179318006076672635443338908659593958290563832266131992829026788067520876689250171169620703222104321626954862629631361443814975870122034080588795445474924618569536486444924104432077134494704956584678850987433944221254487706647809158846074998871240076521705751797883416625624940758906970400028121042762177111777805315317141011704666599146697987317613560067087480711" ++ error "A001622"++a001622_k :: Floating n => n+a001622_k = (1 + sqrt 5) / 2++{- |  <http://oeis.org/A001644>++a(n) = a(n-1) + a(n-2) + a(n-3), a(0)=3, a(1)=1, a(2)=3.++[3,1,3,7,11,21,39,71,131,241,443,815,1499,2757,5071,9327,17155,31553,58035,106743] `isPrefixOf` a001644+-}+a001644 :: Num n => [n]+a001644 = 3 : 1 : 3 : zipWith3 (((+) .) . (+)) a001644 (tail a001644) (drop 2 a001644)++{- | <https://oeis.org/A001653>++Numbers k such that 2*k^2 - 1 is a square.++> [1, 5, 29, 169, 985, 5741, 33461, 195025, 1136689, 6625109, 38613965, 225058681, 1311738121, 7645370045, 44560482149] `isPrefixOf` a001653++-}+a001653 :: [Integer]+a001653 = 1 : 5 : zipWith (-) (map (* 6) (tail a001653)) a001653++{- | <http://oeis.org/A001687>++a(n) = a(n-2) + a(n-5).++[0,1,0,1,0,1,1,1,2,1,3,2,4,4,5,7,7,11,11,16,18,23,29,34,45,52,68,81,102,126,154] `isPrefixOf` a001687+-}+a001687 :: Num n => [n]+a001687 = 0 : 1 : 0 : 1 : 0 : zipWith (+) a001687 (drop 3 a001687)++{- | <https://oeis.org/A001950>++Upper Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi^2), where phi = (1+sqrt(5))/2++> [2,5,7,10,13,15,18,20,23,26,28,31,34,36,39,41,44,47,49,52,54,57,60,62,65] `isPrefixOf` a001950+-}+a001950 :: Integral n => [n]+a001950 = zipWith (+) a000201 [1..]++-- | <http://oeis.org/A002267>+--+-- The 15 supersingular primes.+a002267 :: Num n => [n]+a002267 = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 41, 47, 59, 71]++{- | <https://oeis.org/A002487>++Stern's diatomic series (or Stern-Brocot sequence)++> [0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5] `isPrefixOf` a002487+-}+a002487 :: Num n => [n]+a002487 =+  let f (a:a') (b:b') = a + b : a : f a' b'+      f _ _ = error "a002487"+      x = 1 : 1 : f (tail x) x+  in 0 : x++{- | <https://oeis.org/A002858>++Ulam numbers: a(1) = 1; a(2) = 2; for n>2, a(n) = least number > a(n-1) which is a unique sum of two distinct earlier terms.++> [1, 2, 3, 4, 6, 8, 11, 13, 16, 18, 26, 28, 36, 38, 47, 48, 53, 57, 62, 69, 72, 77, 82, 87, 97, 99, 102, 106, 114, 126] `isPrefixOf` a002858+-}+a002858 :: [Integer]+a002858 = 1 : 2 : ulam 2 2 a002858++ulam :: Int -> Integer -> [Integer] -> [Integer]+ulam n u us =+  let u' = f (0 :: Integer) (u + 1) us'+      f 2 z _                         = f 0 (z + 1) us'+      f e z (v:vs) | z - v <= v       = if e == 1 then z else f 0 (z + 1) us'+                   | z - v `elem` us' = f (e + 1) z vs+                   | otherwise        = f e z vs+      f _ _ []                        = error "ulam?"+      us' = take n us+  in u' : ulam (n + 1) u' us++{- | <http://oeis.org/A003108>++Number of partitions of n into cubes.++> [1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,4,4,4,5,5,5,5,5,6,6,6,7,7,7,7] `isPrefixOf` a003108+-}+a003108 :: Num n => [n]+a003108 =+  let p _ 0 = 1+      p ks'@(k:ks) m = if m < k then 0 else p ks' (m - k) + p ks m+      p _ _ = error "A003108"+  in map (p (tail a000578)) [0::Integer ..]++a003215_n :: Num n => n -> n+a003215_n n = 3 * n * (n + 1) + 1++{- | <http://oeis.org/A003215>++Hex (or centered hexagonal) numbers: 3*n*(n+1)+1 (crystal ball sequence for hexagonal lattice).++> [1,7,19,37,61,91,127,169,217,271,331,397,469,547,631,721,817,919,1027,1141] `isPrefixOf` a003215+-}+a003215 :: (Enum n,Num n) => [n]+a003215 = map a003215_n [0..]++-- | <http://oeis.org/A003269>+--+-- > [0,1,1,1,1,2,3,4,5,7,10,14,19,26,36,50,69,95,131,181,250,345,476,657] `isPrefixOf` a003269+a003269 :: Num n => [n]+a003269 = 0 : 1 : 1 : 1 : zipWith (+) a003269 (drop 3 a003269)++{- | <http://oeis.org/A003520>++a(n) = a(n-1) + a(n-5); a(0) = ... = a(4) = 1.++> [1,1,1,1,1,2,3,4,5,6,8,11,15,20,26,34,45,60,80,106,140,185,245,325,431] `isPrefixOf` a003520+-}+a003520 :: Num n => [n]+a003520 = 1 : 1 : 1 : 1 : 1 : zipWith (+) a003520 (drop 4 a003520)++{- | <http://oeis.org/A003462>++a(n) = (3^n - 1)/2. (Formerly M3463)++[0, 1, 4, 13, 40, 121, 364, 1093, 3280, 9841, 29524, 88573, 265720, 797161, 2391484, 7174453] `isPrefixOf` a003462+-}+a003462 :: [Integer]+a003462 = iterate ((+ 1) . (* 3)) 0++a003462_n :: Integer -> Integer+a003462_n = (`div` 2) . (subtract 1) . (3 ^)++{- | <http://oeis.org/A003586>++3-smooth numbers: numbers of the form 2^i*3^j with i, j >= 0++[1, 2, 3, 4, 6, 8, 9, 12, 16, 18, 24, 27, 32, 36, 48, 54, 64, 72, 81, 96, 108, 128, 144, 162] `isPrefixOf` a003586+-}+a003586 :: [Integer]+a003586 =+  let smooth s = let (x, s') = Set.deleteFindMin s in x : smooth (Set.insert (3 * x) (Set.insert (2 * x) s'))+  in  smooth (Set.singleton 1)++{- | <https://oeis.org/A003849>++The infinite Fibonacci word (start with 0, apply 0->01, 1->0, take limit).++> [0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0,0,1,0,0,1,0,1,0] `isPrefixOf` a003849+-}+a003849 :: Num n => [n]+a003849 =+  let fws = [1] : [0] : zipWith (++) fws (tail fws)+  in tail (concat fws)++{- | <http://oeis.org/A004001>++Hofstadter-Conway sequence: a(n) = a(a(n-1)) + a(n-a(n-1)) with a(1) = a(2) = 1.++> [1,1,2,2,3,4,4,4,5,6,7,7,8,8,8,8,9,10,11,12,12,13,14,14,15,15,15,16,16,16,16,16] `isPrefixOf` a004001++> plot_p1_ln [take 250 a004001]+> plot_p1_ln [zipWith (-) a004001 (map (`div` 2) [1 .. 2000])]++-}+a004001 :: [Int]+a004001 =+  let h n x =+        let x' = a004001 !! (x - 1) + a004001 !! (n - x - 1)+        in x' : h (n + 1) x'+  in 1 : 1 : h 3 1++{- | <http://oeis.org/A004718>++Per Nørgård's "infinity sequence"++> take 32 a004718 == [0,1,-1,2,1,0,-2,3,-1,2,0,1,2,-1,-3,4,1,0,-2,3,0,1,-1,2,-2,3,1,0,3,-2,-4,5]++> plot_p1_imp [take 1024 a004718]++<https://www.tandfonline.com/doi/abs/10.1080/17459737.2017.1299807>+<https://arxiv.org/pdf/1402.3091.pdf>++-}+a004718 :: Num n => [n]+a004718 = 0 : concat (transpose [map (+ 1) a004718, map negate (tail a004718)])++{- | <http://oeis.org/A005185>++Hofstadter Q-sequence: a(1) = a(2) = 1; a(n) = a(n-a(n-1)) + a(n-a(n-2)) for n > 2.++> [1,1,2,3,3,4,5,5,6,6,6,8,8,8,10,9,10,11,11,12,12,12,12,16,14,14,16,16,16,16,20] `isPrefixOf` a005185+-}+a005185 :: [Int]+a005185 =+  let ix n = a005185 !! (n - 1)+      zadd = zipWith (+)+      zsub = zipWith (-)+  in 1 : 1 : zadd (map ix (zsub [3..] a005185)) (map ix (zsub [3..] (tail a005185)))++{- | <https://oeis.org/A005448>++Centered triangular numbers: a(n) = 3n(n-1)/2 + 1.++> [1,4,10,19,31,46,64,85,109,136,166,199,235,274,316,361,409,460,514,571,631,694] `isPrefixOf` a005448++> map a005448_n [1 .. 1000] `isPrefixOf` a005448+-}+a005448 :: Integral n => [n]+a005448 = 1 : zipWith (+) a005448 [3,6 ..]++a005448_n :: Integral n => n -> n+a005448_n n = 3 * n * (n - 1) `div` 2 + 1++{- | <http://oeis.org/A005728>++Number of fractions in Farey series of order n.++> [1,2,3,5,7,11,13,19,23,29,33,43,47,59,65,73,81,97,103,121,129,141,151] `isPrefixOf` a005728+-}+a005728 :: Integral i => [i]+a005728 =+  let phi n = genericLength (filter (==1) (map (gcd n) [1..n]))+      f n = if n == 0 then 1 else f (n - 1) + phi n+  in map f [0::Integer ..]++{- | <http://oeis.org/A005811>++Number of runs in binary expansion of n (n>0); number of 1's in Gray code for n++> take 32 a005811 == [0,1,2,1,2,3,2,1,2,3,4,3,2,3,2,1,2,3,4,3,4,5,4,3,2,3,4,3,2,3,2,1]+-}+a005811 :: Integral n => [n]+a005811 =+  let f (x:xs) = x : f (xs ++ [x + x `mod` 2, x + 1 - x `mod` 2])+      f _ = error "A005811"+  in 0 : f [1]++{- | <http://oeis.org/A005917>++Rhombic dodecahedral numbers: a(n) = n^4 - (n - 1)^4.++> [1,15,65,175,369,671,1105,1695,2465,3439,4641,6095,7825,9855,12209,14911,17985] `isPrefixOf` a005917+-}+a005917 :: Integral n => [n]+a005917 =+  let f x ws = let (us,vs) = splitAt x ws in us : f (x + 2) vs+  in map sum (f 1 [1, 3 ..])++{- | <https://oeis.org/A006003>++a(n) = n*(n^2 + 1)/2.++> [0,1,5,15,34,65,111,175,260,369,505,671,870,1105,1379,1695,2056,2465,2925,3439] `isPrefixOf` a006003++> map a006003_n [0 .. 1000] `isPrefixOf` a006003+-}+a006003 :: Integral n => [n]+a006003 = scanl (+) 0 a005448++a006003_n :: Integral n => n -> n+a006003_n n = n * (n ^ (2::Int) + 1) `div` 2++{- | <http://oeis.org/A006046>++Total number of odd entries in first n rows of Pascal's triangle: a(0) = 0, a(1) = 1, a(2k) = 3*a(k), a(2k+1) = 2*a(k) + a(k+1).++> [0,1,3,5,9,11,15,19,27,29,33,37,45,49,57,65,81,83,87,91,99,103,111,119,135,139] `isPrefixOf` a006046++> import Sound.SC3.Plot {- hsc3-plot -}+> plot_p1_ln [take 250 a006046]+> let t = log 3 / log 2+> plot_p1_ln [zipWith (/) (map fromIntegral a006046) (map (\n -> n ** t) [0.0,1 .. 200])]+-}+a006046 :: [Int]+a006046 = map (sum . concat) (inits a047999_tbl)++{- | <http://oeis.org/A006052>++Number of magic squares of order n composed of the numbers from 1 to n^2, counted up to rotations and reflections.++> [1,0,1,880,275305224] == a006052+-}+a006052 :: Integral n => [n]+a006052 = [1,0,1,880,275305224]++{- | <http://oeis.org/A006842>++Triangle read by rows: row n gives numerators of Farey series of order n.++> [0,1,0,1,1,0,1,1,2,1,0,1,1,1,2,3,1,0,1,1,1,2,1,3,2,3,4,1,0,1,1,1,1,2,1,3] `isPrefixOf` a006842+> plot_p1_imp [take 200 (a006842 :: [Int])]+> plot_p1_pt [take 10000 (a006842 :: [Int])]+-}+a006842 :: Integral i => [i]+a006842 = map numerator (concatMap Math.farey [1..])++{- | <http://oeis.org/A006843>++Triangle read by rows: row n gives denominators of Farey series of order n++> [1,1,1,2,1,1,3,2,3,1,1,4,3,2,3,4,1,1,5,4,3,5,2,5,3,4,5,1,1,6,5,4,3,5,2,5] `isPrefixOf` a006843+> plot_p1_imp [take 200 (a006843 :: [Int])]+> plot_p1_pt [take 10000 (a006843 :: [Int])]+-}+a006843 :: Integral i => [i]+a006843 = map denominator (concatMap Math.farey [1..])++{- | <https://oeis.org/A007318>++Pascal's triangle read by rows++[[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1],[1,5,10,10,5,1]] `isPrefixOf` a007318_tbl+-}+a007318 :: Integral i => [i]+a007318 = concat a007318_tbl++a007318_tbl :: Integral i => [[i]]+a007318_tbl =+  let f r = zipWith (+) (0 : r) (r ++ [0])+  in iterate f [1]++{- | <https://oeis.org/A008277>++Triangle of Stirling numbers of the second kind, S2(n,k), n >= 1, 1 <= k <= n.++[1,1,1,1,3,1,1,7,6,1,1,15,25,10,1,1,31,90,65,15,1,1,63,301,350,140,21,1] `isPrefixOf` a008277+-}+a008277 :: (Enum n,Num n) => [n]+a008277 = concat a008277_tbl++a008277_tbl :: (Enum n,Num n) => [[n]]+a008277_tbl = map tail a048993_tbl++{- | <http://oeis.org/A008278>++Triangle of Stirling numbers of 2nd kind, S(n,n-k+1), n >= 1, 1<=k<=n.++[1,1,1,1,3,1,1,6,7,1,1,10,25,15,1,1,15,65,90,31,1,1,21,140,350,301,63,1] `isPrefixOf` a008278+-}+a008278 :: (Enum n,Num n) => [n]+a008278 = concat a008278_tbl++a008278_tbl :: (Enum n,Num n) => [[n]]+a008278_tbl =+  let f p =+        let q = reverse (zipWith (*) [1..] (reverse p))+        in zipWith (+) (0 : q) (p ++ [0])+  in iterate f [1]++{- | <http://oeis.org/A008683>++Möbius (or Moebius) function mu(n). mu(1) = 1; mu(n) = (-1)^k if n is the product of k different primes; otherwise mu(n) = 0.++> [1,-1,-1,0,-1,1,-1,0,0,1,-1,0,-1,1,1,0,-1,0,-1,0,1,1,-1,0,0,1,0,0,-1,-1,-1,0,1] `isPrefixOf` a008683+-}+a008683 :: Integral n => [n]+a008683 = map a008683_n [1..]++a008683_n :: Integral n => n -> n+a008683_n =+  let mu [] = 1+      mu (1:es) = - mu es+      mu _ = 0+  in mu . snd . unzip . Prime.prime_factors_m ++{- | <http://oeis.org/A010049>++Second-order Fibonacci numbers.++> [0,1,1,3,5,10,18,33,59,105,185,324,564,977,1685,2895,4957,8462,14406,24465,41455] `isInfixOf` a010049+-}+a010049 :: Num n => [n]+a010049 =+  let c us (v:vs) = sum (zipWith (*) us (1 : reverse us)) : c (v:us) vs+      c _ _ = error "A010049"+  in uncurry c (splitAt 1 a000045)++{- | <https://oeis.org/A010060>++Thue-Morse sequence: let A_k denote the first 2^k terms; then A_0 = 0 and for k >= 0, A_{k+1} = A_k B_k, where B_k is obtained from A_k by interchanging 0's and 1's.++[0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1, 0, 0] `isPrefixOf` a010060++-}+a010060 :: [Integer]+a010060 =+  let interleave (x:xs) ys = x : interleave ys xs+      interleave [] _ = error "a010060?"+   in 0 : interleave (map (1 -) a010060) (tail a010060)++{- | <https://oeis.org/A014081>++a(n) is the number of occurrences of '11' in binary expansion of n.++> [0, 0, 0, 1, 0, 0, 1, 2, 0, 0, 0, 1, 1, 1, 2, 3, 0, 0, 0, 1, 0, 0, 1, 2, 1, 1, 1, 2, 2, 2, 3, 4, 0, 0, 0, 1, 0, 0, 1, 2] `isPrefixOf` a014081++-}+a014081 :: (Integral i, Bits i) => [i]+a014081 = map (\n -> a000120 !! (n .&. div n 2)) [0..]++{- | <https://oeis.org/A014577>++The regular paper-folding sequence (or dragon curve sequence).++> [1, 1, 0, 1, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 1, 1] `isPrefixOf` a014577+-}+a014577 :: Integral i => [i]+a014577 =+  let f n = if n `rem` 2 == 1 then f (n `quot` 2) else 1 - (n `div` 2 `rem` 2)+  in map f [0..]++{- | <http://oeis.org/A016813>++a(n) = 4*n + 1.++> [1,5,9,13,17,21,25,29,33,37,41,45,49,53,57,61,65,69,73,77,81,85,89,93,97,101] `isPrefixOf` a016813+-}+a016813 :: Integral n => [n]+a016813 = [1, 5 ..]++{- | <http://oeis.org/A017817>++a(n) = a(n-3) + a(n-4), with a(0)=1, a(1)=a(2)=0, a(3)=1++> [1,0,0,1,1,0,1,2,1,1,3,3,2,4,6,5,6,10,11,11,16,21,22,27,37,43,49,64,80,92] `isPrefixOf` a017817+-}+a017817 :: Num n => [n]+a017817 = 1 : 0 : 0 : 1 : zipWith (+) a017817 (tail a017817)++{- | <http://oeis.org/A020695>++Pisot sequence E(2,3).++> [2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181,6765,10946,17711] `isPrefixOf` a020695+-}+a020695 :: Num n => [n]+a020695 = drop 3 a000045++{- | <https://oeis.org/A020985>++The Rudin-Shapiro or Golay-Rudin-Shapiro sequence (coefficients of the Shapiro polynomials).		45++> [1, 1, 1, -1, 1, 1, -1, 1, 1, 1, 1, -1, -1, -1, 1, -1, 1, 1, 1, -1, 1, 1, -1, 1, -1, -1, -1, 1, 1, 1, -1, 1, 1, 1, 1, -1] `isPrefixOf` a020985+-}+a020985 :: [Integer]+a020985 =+  let f (x:xs) w = x : x*w : f xs (0 - w)+      f [] _ = error "a020985?"+  in 1 : 1 : f (tail a020985) (-1)++{- | <http://oeis.org/A022095>++Fibonacci sequence beginning 1, 5.++> [1,5,6,11,17,28,45,73,118,191,309,500,809,1309,2118,3427,5545,8972,14517,23489] `isPrefixOf` a022095+-}+a022095 :: Num n => [n]+a022095 = 1 : 5 : zipWith (+) a022095 (tail a022095)++{- | <http://oeis.org/A022096>++Fibonacci sequence beginning 1, 6.++> [1,6,7,13,20,33,53,86,139,225,364,589,953,1542,2495,4037,6532,10569,17101,27670] `isPrefixOf` a022096+-}+a022096 :: Num n => [n]+a022096 = 1 : 6 : zipWith (+) a022096 (tail a022096)++{- | <https://oeis.org/A027750>++Triangle read by rows in which row n lists the divisors of n.++> [1,1,2,1,3,1,2,4,1,5,1,2,3,6,1,7,1,2,4,8,1,3,9,1,2,5,10,1,11,1,2,3,4,6,12,1,13] `isPrefixOf` a027750+-}+a027750 :: Integral n => [n]+a027750 = concatMap a027750_row [1..]++a027750_row :: Integral n => n -> [n]+a027750_row n = filter ((== 0) . (mod n)) [1..n]++{- | <http://oeis.org/A027934>++a(0)=0, a(1)=1, a(2)=2; for n > 2, a(n) = 3*a(n-1) - a(n-2) - 2*a(n-3).++> [0,1,2,5,11,24,51,107,222,457,935,1904,3863,7815,15774,31781,63939,128488] `isPrefixOf` a027934+-}+a027934 :: Num n => [n]+a027934 =+  let f x y z = 3 * x - y - 2 * z+  in 0 : 1 : 2 : zipWith3 f (drop 2 a027934) (tail a027934) a027934++{- | <http://oeis.org/A029635>++The (1,2)-Pascal triangle (or Lucas triangle) read by rows.++> [2,1,2,1,3,2,1,4,5,2,1,5,9,7,2,1,6,14,16,9,2,1,7,20,30,25,11,2,1,8,27,50,55,36] `isPrefixOf` a029635+> take 7 a029635_tbl == [[2],[1,2],[1,3,2],[1,4,5,2],[1,5,9,7,2],[1,6,14,16,9,2],[1,7,20,30,25,11,2]]+-}+a029635 :: Num i => [i]+a029635 = concat a029635_tbl++a029635_tbl :: Num i => [[i]]+a029635_tbl =+  let f r = zipWith (+) (0 : r) (r ++ [0])+  in [2] : iterate f [1,2]++{- | <http://oeis.org/A030308>++Triangle T(n,k): Write n in base 2, reverse order of digits, to get the n-th row++> take 9 a030308 == [[0],[1],[0,1],[1,1],[0,0,1],[1,0,1],[0,1,1],[1,1,1],[0,0,0,1]]+-}+a030308 :: (Eq n,Num n) => [[n]]+a030308 =+   let f l = case l of+         [] -> [1]+         0:b -> 1 : b+         1:b -> 0 : f b+         _ -> error "A030308"+   in iterate f [0]++{- | <https://oeis.org/A033622>++Good sequence of increments for Shell sort (best on big values).++[1, 5, 19, 41, 109, 209, 505, 929, 2161, 3905, 8929, 16001, 36289, 64769, 146305, 260609, 587521] `isPrefixOf` a033622+-}+a033622 :: [Integer]+a033622 = map a033622_n [0..]++a033622_n :: Integer -> Integer+a033622_n n =+  if even n+  then 9 * 2 ^ n - 9 * 2 ^ ( n `div` 2) + 1+  else 8 * 2 ^ n - 6 * 2 ^ ((n + 1 )`div` 2) + 1++{- | <http://oeis.org/A033812>++The Loh-Shu 3 X 3 magic square, lexicographically largest variant when read by columns.+-}+a033812 :: Num n => [n]+a033812 = [8, 1, 6, 3, 5, 7, 4, 9, 2]++{- | <http://oeis.org/A034968>++Minimal number of factorials that add to n.++> [0,1,1,2,2,3,1,2,2,3,3,4,2,3,3,4,4,5,3,4,4,5,5,6,1,2,2,3,3,4,2,3,3,4,4,5,3,4,4] `isPrefixOf` a034968+-}+a034968 :: Integral n => [n]+a034968 =+  let f i s n = if n == 0 then s else f (i + 1) (s + rem n i) (quot n i)+  in map (f 2 0) [0 ..]++{- | <https://oeis.org/A036562>++a(n) = 4^(n+1) + 3*2^n + 1++[1, 8, 23, 77, 281, 1073, 4193, 16577, 65921, 262913, 1050113, 4197377, 16783361, 67121153] `isPrefixOf` a036562+-}+a036562 :: [Integer]+a036562 = 1 : map a036562_n [0..]++a036562_n :: Integer -> Integer+a036562_n n = 4^(n+1) + 3*2^n + 1++{- | <http://oeis.org/A046042>++Number of partitions of n into fourth powers.++> [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3] `isPrefixOf` a046042+-}+a046042 :: Num n => [n]+a046042 =+  let p _ 0 = 1+      p ks'@(k:ks) m = if m < k then 0 else p ks' (m - k) + p ks m+      p _ _ = error "A046042"+  in map (p (tail a000583)) [1::Integer ..]++{- | <http://oeis.org/A047999>++Sierpiński's triangle (or gasket): triangle, read by rows, formed by reading Pascal's triangle mod 2.++> [1,1,1,1,0,1,1,1,1,1,1,0,0,0,1,1,1,0,0,1,1,1,0,1,0,1,0,1,1,1,1,1,1,1,1,1,1,0,0] `isPrefixOf` a047999+-}+a047999 :: [Int]+a047999 = concat a047999_tbl++a047999_tbl :: [[Int]]+a047999_tbl = iterate (\r -> zipWith xor (0 : r) (r ++ [0])) [1]++{- | <https://oeis.org/A048993>++Triangle of Stirling numbers of 2nd kind, S(n,k), n >= 0, 0 <= k <= n.++> [1,0,1,0,1,1,0,1,3,1,0,1,7,6,1,0,1,15,25,10,1,0,1,31,90,65,15,1] `isPrefixOf` a048993+-}+a048993 :: (Enum n,Num n) => [n]+a048993 = concat a048993_tbl++a048993_tbl :: (Enum n,Num n) => [[n]]+a048993_tbl = iterate (\row -> 0 : zipWith (+) row (zipWith (*) [1..] (tail row)) ++ [1]) [1]++{- | <http://oeis.org/A049455>++Triangle read by rows, numerator of fractions of a variant of the Farey series.++> [0,1,0,1,1,0,1,1,2,1,0,1,1,2,1,3,2,3,1,0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,0] `isPrefixOf` a049455+> plot_p1_imp [take 200 (a049455 :: [Int])]+> plot_p1_pt [take 10000 (a049455 :: [Int])]+-}+a049455 :: Integral n => [n]+a049455 = map fst (concat Math.stern_brocot_tree_lhs)++{- | <http://oeis.org/A049456>++Triangle read by rows, denominator of fractions of a variant of the Farey series.++[1,1,1,2,1,1,3,2,3,1,1,4,3,5,2,5,3,4,1,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5,1,1,6,5,9] `isPrefixOf` a049456+> plot_p1_imp [take 200 (a049456 :: [Int])]+> plot_p1_pt [take 10000 (a049456 :: [Int])]+-}+a049456 :: Integral n => [n]+a049456 = map snd (concat Math.stern_brocot_tree_lhs)++{- | <http://oeis.org/A053121>++Catalan triangle (with 0's) read by rows.++> [1,0,1,1,0,1,0,2,0,1,2,0,3,0,1,0,5,0,4,0,1,5,0,9,0,5,0,1,0,14,0,14,0,6,0,1,14,0] `isPrefixOf` a053121+> take 7 a053121_tbl == [[1],[0,1],[1,0,1],[0,2,0,1],[2,0,3,0,1],[0,5,0,4,0,1],[5,0,9,0,5,0,1]]+-}+a053121 :: Num n => [n]+a053121 = concat a053121_tbl++a053121_tbl :: Num n => [[n]]+a053121_tbl = iterate (\row -> zipWith (+) (0 : row) (tail row ++ [0, 0])) [1]++{- | <http://oeis.org/A058265>++Decimal expansion of the tribonacci constant t, the real root of x^3 - x^2 - x - 1.++> [1,8,3,9,2,8,6,7,5,5,2,1,4,1,6,1,1,3,2,5,5,1,8,5,2,5,6,4,6,5,3,2,8,6,6,0,0,4,2] `isPrefixOf` a058265++> a058265_k :: Data.Number.Fixed.Fixed Data.Number.Fixed.Prec500 {- numbers -}+-}+a058265 :: Num n => [n]+a058265 = map (fromIntegral . digitToInt) "183928675521416113255185256465328660042417874609759224677875863940420322208196642573843541942830701414197982685924097416417845074650743694383154582049951379624965553964461366612154027797267811894104121160922328215595607181671218236598665227337853781569698925211739579141322872106187898408525495693114534913498534595761750359652213238142472727224173581877000697905510254904496571074252654772281100659893755563630933305282623575385197199429914530082546639774729005870059744813919316728258488396263329709" ++ error "A058265"++-- | A058265 as 'Floating' calculation, see "Data.Number.Fixed".+a058265_k :: Floating n => n+a058265_k = (1/3) * (1 + (19 + 3 * sqrt 33) ** (1/3) + (19 - 3 * sqrt 33)  ** (1/3))++{- | <http://oeis.org/A060588>++If the final two digits of n written in base 3 are the same then this digit, otherwise mod 3-sum of these two digits.++> [0,2,1,2,1,0,1,0,2,0,2,1,2,1,0,1,0,2,0,2,1,2,1,0,1,0,2,0,2,1,2,1,0,1,0,2,0,2,1] `isPrefixOf` a060588a+-}+a060588a :: Integral n => [n]+a060588a = map a060588a_n [0..]++a060588a_n :: Integral n => n -> n+a060588a_n n = (-n - floor (fromIntegral n / (3::Double))) `mod` 3++{- | <http://oeis.org/A061654>++a(n) = (3*16^n + 2)/5++> [1,10,154,2458,39322,629146,10066330,161061274,2576980378,41231686042] `isPrefixOf` a061654+-}+a061654 :: Integral n => [n]+a061654 = map a061654_n [0 ..]++a061654_n :: Integral n => n -> n+a061654_n n = (3 * 16^n + 2) `div` 5++{- | <http://oeis.org/A071996>++a(1) = 0, a(2) = 1, a(n) = a(floor(n/3)) + a(n - floor(n/3)).++> [0,1,1,1,1,2,2,3,3,3,4,4,4,4,4,5,5,6,6,6,6,6,7,8,8,9,9,9,9,9,9,9,10,11,12,12,12] `isPrefixOf` a071996++> plot_p1_ln [take 50 a000201 :: [Int]]+> plot_p1_imp [map length (take 250 (group a071996))]+-}+a071996 :: Integral n => [n]+a071996 =+  let f n =+        case n of+          0 -> error "A071996"+          1 -> 0+          2 -> 1+          _ -> let m = floor (fromIntegral n / (3::Double)) in f m + f (n - m)+  in map f [1::Int ..]++{- | <http://oeis.org/A073334>++The "rhythmic infinity system" of Danish composer Per Nørgård++> take 24 a073334 == [3,5,8,5,8,13,8,5,8,13,21,13,8,13,8,5,8,13,21,13,21,34,21,13]+> plot_p1_imp [take 200 (a073334 :: [Int])]+-}+a073334 :: Num n => [n]+a073334 =+  let f n = a000045 !! ((a005811 !! n) + 4)+  in 3 : map f [1..]++{- | <https://oeis.org/A080843>++Tribonacci word: limit S(infinity), where S(0) = 0, S(1) = 0,1, S(2) = 0,1,0,2 and for n >= 0, S(n+3) = S(n+2) S(n+1) S(n).++> [0,1,0,2,0,1,0,0,1,0,2,0,1,0,1,0,2,0,1,0,0,1,0,2,0,1,0,2,0,1,0,0,1,0,2,0,1,0,1] `isPrefixOf` a080843+-}+a080843 :: Integral n => [n]+a080843 =+  let rw n = case n of {0 -> [0,1];1 -> [0,2];2 -> [0];_ -> error "A080843"}+      unf = let f n l = case l of {[] -> error "A080843";x:xs -> drop n x ++ f (length x) xs} in f 0+  in unf (iterate (concatMap rw) [0])++{- | <http://oeis.org/A080992>++Entries in Durer's magic square.++> [16,3,2,13,5,10,11,8,9,6,7,12,4,15,14,1] == a080992+-}+a080992 :: Num n => [n]+a080992 =+  [16,03,02,13+  ,05,10,11,08+  ,09,06,07,12+  ,04,15,14,01]++{- | <http://oeis.org/A083866>++Positions of zeros in Per Nørgård's infinity sequence (A004718).++> take 24 a083866 == [0,5,10,17,20,27,34,40,45,54,65,68,75,80,85,90,99,105,108,119,130,136,141,150]+-}+a083866 :: (Enum n,Num n) => [n]+a083866 = map snd (filter ((== (0::Int)) . fst) (zip a004718 [0..]))++{- | <http://oeis.org/A095660>++Pascal (1,3) triangle.++> [3,1,3,1,4,3,1,5,7,3,1,6,12,10,3,1,7,18,22,13,3,1,8,25,40,35,16,3,1,9,33,65,75] `isPrefixOf` a095660+> take 6 a095660_tbl == [[3],[1,3],[1,4,3],[1,5,7,3],[1,6,12,10,3],[1,7,18,22,13,3]]+-}+a095660 :: Num i => [i]+a095660 = concat a095660_tbl++a095660_tbl :: Num i => [[i]]+a095660_tbl =+  let f r = zipWith (+) (0 : r) (r ++ [0])+  in [3] : iterate f [1,3]++{- | <http://oeis.org/A095666>++Pascal (1,4) triangle.++> [4,1,4,1,5,4,1,6,9,4,1,7,15,13,4,1,8,22,28,17,4,1,9,30,50,45,21,4,1,10,39,80,95] `isPrefixOf` a095666+> take 6 a095666_tbl == [[4],[1,4],[1,5,4],[1,6,9,4],[1,7,15,13,4],[1,8,22,28,17,4]]+-}+a095666 :: Num i => [i]+a095666 = concat a095666_tbl++a095666_tbl :: Num i => [[i]]+a095666_tbl =+  let f r = zipWith (+) (0 : r) (r ++ [0])+  in [4] : iterate f [1,4]++{- | <http://oeis.org/A096940>++Pascal (1,5) triangle.++> [5,1,5,1,6,5,1,7,11,5,1,8,18,16,5,1,9,26,34,21,5,1,10,35,60,55,26,5,1,11,45,95] `isPrefixOf` a096940+> take 6 a096940_tbl == [[5],[1,5],[1,6,5],[1,7,11,5],[1,8,18,16,5],[1,9,26,34,21,5]]+-}+a096940 :: Num i => [i]+a096940 = concat a096940_tbl++a096940_tbl :: Num i => [[i]]+a096940_tbl =+  let f r = zipWith (+) (0 : r) (r ++ [0])+  in [5] : iterate f [1,5]++{- | <http://oeis.org/A105809>++A Fibonacci-Pascal matrix.++> [1,1,1,2,2,1,3,4,3,1,5,7,7,4,1,8,12,14,11,5,1,13,20,26,25,16,6,1,21,33,46,51,41] `isPrefixOf` a105809+-}+a105809 :: Num n => [n]+a105809 = concat a105809_tbl++a105809_tbl :: Num n => [[n]]+a105809_tbl =+  let f (u:_, vs) = (vs, zipWith (+) (u : vs) (vs ++ [0]))+      f _ = error "A105809"+  in map fst (iterate f ([1], [1, 1]))++{- | <http://oeis.org/A124010>++Triangle in which first row is 0, n-th row (n>1) lists the (ordered)+prime signature of n, that is, the exponents of distinct prime factors+in factorization of n.++> [0,1,1,2,1,1,1,1,3,2,1,1,1,2,1,1,1,1,1,1,4,1,1,2,1,2,1,1,1,1,1,1,3,1,2,1,1,3,2,1,1,1,1,1,1,5,1] `isPrefixOf` a124010+-}+a124010 :: Integral n => [n]+a124010 = concatMap a124010_row [1..]++a124010_row :: Integral n => n -> [n]+a124010_row n =+  let f u w =+        case (u, w) of+          (1, _) -> []+          (_, p:ps) ->+            let h v e =+                  let (v', m) = divMod v p+                  in if m == 0+                     then h v' (e + 1)+                     else if e > 0+                          then e : f v ps+                          else f v ps+            in h u 0+          _ -> error "a124010"+  in if n == 1 then [0] else f n a000040++{- | <https://oeis.org/A124472>++Benjamin Franklin's 16 X 16 magic square read by rows.++> [200,217,232,249,8,25,40,57,72,89,104,121,136,153,168,185,58,39,26,7,250,231] `isPrefixOf` a124472+-}+a124472 :: Num n => [n]+a124472 =+  concat+  [[200,217,232,249,8,25,40,57,72,89,104,121,136,153,168,185]+  ,[58,39,26,7,250,231,218,199,186,167,154,135,122,103,90,71]+  ,[198,219,230,251,6,27,38,59,70,91,102,123,134,155,166,187]+  ,[60,37,28,5,252,229,220,197,188,165,156,133,124,101,92,69]+  ,[201,216,233,248,9,24,41,56,73,88,105,120,137,152,169,184]+  ,[55,42,23,10,247,234,215,202,183,170,151,138,119,106,87,74]+  ,[203,214,235,246,11,22,43,54,75,86,107,118,139,150,171,182]+  ,[53,44,21,12,245,236,213,204,181,172,149,140,117,108,85,76]+  ,[205,212,237,244,13,20,45,52,77,84,109,116,141,148,173,180]+  ,[51,46,19,14,243,238,211,206,179,174,147,142,115,110,83,78]+  ,[207,210,239,242,15,18,47,50,79,82,111,114,143,146,175,178]+  ,[49,48,17,16,241,240,209,208,177,176,145,144,113,112,81,80]+  ,[196,221,228,253,4,29,36,61,68,93,100,125,132,157,164,189]+  ,[62,35,30,3,254,227,222,195,190,163,158,131,126,99,94,67]+  ,[194,223,226,255,2,31,34,63,66,95,98,127,130,159,162,191]+  ,[64,33,32,1,256,225,224,193,192,161,160,129,128,97,96,65]]++{- | <http://oeis.org/A125519>++A 4 x 4 permutation-free magic square.+-}+a125519 :: Num n => [n]+a125519 = [831,326,267,574,584,257,316,841,158,683,742,415,425,732,673,168]++{- | <http://oeis.org/A126275>++Moment of inertia of all magic squares of order n.++> [5,60,340,1300,3885,9800,21840,44280,83325,147620,248820,402220,627445,949200] `isPrefixOf` a126275+-}+a126275 :: Integral n => [n]+a126275 = map a126275_n [2..]++a126275_n :: Integral n => n -> n+a126275_n n = (n ^ (2::Int) * (n ^ (4::Int) - 1)) `div` 12++{- | <http://oeis.org/A126276>++Moment of inertia of all magic cubes of order n.++> [18,504,5200,31500,136710,471968,1378944,3547800,8258250,17728920,35603568] `isPrefixOf` a126276+-}+a126276 :: Integral n => [n]+a126276 = map a126276_n [2..]++a126276_n :: Integral n => n -> n+a126276_n n = (n ^ (3::Int) * (n ^ (3::Int) + 1) * (n ^ (2::Int) - 1)) `div` 12++{- | <http://oeis.org/A126651>++A 7 x 7 magic square.+-}+a126651 :: Num n => [n]+a126651 =+  [71,  1, 51, 32, 50,  2, 80+  ,21, 41, 61, 56, 26, 13, 69+  ,31, 81, 11, 20, 62, 65, 17+  ,34, 40, 60, 43, 28, 64, 18+  ,48, 42, 22, 54, 39, 75,  7+  ,33, 53, 15, 68, 16, 44, 58+  ,49, 29, 67, 14, 66, 24, 38]++{- | <http://oeis.org/A126652>++A 3 X 3 magic square with magic sum 75: the Loh-Shu square A033812 multiplied by 5.++> a126652 == map (* 5) a033812+-}+a126652 :: Num n => [n]+a126652 = [40, 5, 30, 15, 25, 35, 20, 45, 10]++{- | <http://oeis.org/A126653>++A 3 X 3 magic square with magic sum 45: the Loh-Shu square A033812 multiplied by 3.++> a126653 == map (* 3) a033812+-}+a126653 :: Num n => [n]+a126653 = [24, 3, 18, 9, 15, 21, 12, 27, 6]++{- | <http://oeis.org/A126654>++A 3 x 3 magic square.+-}+a126654 :: Num n => [n]+a126654 = [32, 4, 24, 12, 20, 28, 16, 36, 8]++{- | <http://oeis.org/A126709>++The Loh-Shu 3 x 3 magic square, variant 2.++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]++{- | <http://oeis.org/A126710>++Jaina inscription of the twelfth or thirteenth century, Khajuraho, India.+-}+a126710 :: Num n => [n]+a126710 =+  [ 7,12, 1,14+  , 2,13, 8,11+  ,16, 3,10, 5+  , 9, 6,15, 4]++{- | <http://oeis.org/A126976>++A 6 x 6 magic square read by rows.++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]++{- | <https://oeis.org/A212804>++Expansion of (1 - x)/(1 - x - x^2).++[1,0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181,6765,10946] `isPrefixOf` a212804+-}+a212804 :: Integral n => [n]+a212804 = 1 : a000045++{- | <https://oeis.org/A245553>++A Rauzy fractal sequence: trajectory of 1 under morphism 1 -> 2,3; 2 -> 3; 3 -> 1.++> [1,2,3,2,3,3,1,2,3,3,1,3,1,1,2,3,2,3,3,1,3,1,1,2,3,3,1,1,2,3,1,2,3,2,3,3,1,2,3] `isPrefixOf` a245553+-}+a245553 :: Integral n => [n]+a245553 =+  let rw n = case n of {1 -> [2,3];2 -> [3];3 -> [1];_ -> error "A245553"}+      jn x = x ++ concatMap rw x+      unf = let f n l = case l of {[] -> error "A245553";x:xs -> drop n x ++ f (length x) xs} in f 0+  in unf (iterate jn [1])++{- | <http://oeis.org/A255723>++Another variant of Per Nørgård's "infinity sequence"++> take 24 a255723 == [0,-2,-1,2,-2,-4,1,0,-1,-3,0,1,2,0,-3,4,-2,-4,1,0,-4,-6,3,-2]+> plot_p1_imp [take 400 (a255723 :: [Int])]+-}+a255723 :: Num n => [n]+a255723 = 0 : concat (transpose [map (subtract 2) a255723+                                ,map (-1 -) a255723+                                ,map (+ 2) a255723+                                ,tail a255723])++{- | <http://oeis.org/A256184>++First of two variations by Per Nørgård of his "infinity sequence"++> take 24 a256184 == [0,-2,-1,2,-4,-3,1,-3,-2,-2,0,1,4,-6,-5,3,-5,-4,-1,-1,0,3,-5,-4]+-}+a256184 :: Num n => [n]+a256184 = 0 : concat (transpose [map (subtract 2) a256184+                                ,map (subtract 1) a256184+                                ,map negate (tail a256184)])++{- | <http://oeis.org/A256185>++Second of two variations by Per Nørgård of his "infinity sequence"++> take 24 a256185 == [0,-3,-2,3,-6,1,2,-5,0,-3,0,-5,6,-9,4,-1,-2,-3,-2,-1,-4,5,-8,3]+-}+a256185 :: Num n => [n]+a256185 = 0 : concat (transpose [map (subtract 3) a256185+                                ,map (-2 -) a256185+                                ,map negate (tail a256185)])++{- | <http://oeis.org/A270876>++Number of magic tori of order n composed of the numbers from 1 to n^2.++> [1,0,1,255,251449712] == a270876+-}+a270876 :: Integral n => [n]+a270876 = [1,0,1,255,251449712]++{- | <http://oeis.org/A320872>++For all possible 3 X 3 magic squares made of primes, in order of increasing magic sum, list the lexicographically smallest representative of each equivalence class (modulo symmetries of the square), as a row of the 9 elements (3 rows of 3 elements each).+-}+a320872 :: Num n => [n]+a320872 =+  [17, 89,  71,  113,  59,  5, 47, 29, 101+  ,41, 89,  83,  113,  71, 29, 59, 53, 101+  ,37, 79,  103, 139,  73,  7, 43, 67, 109+  ,29, 131, 107, 167,  89, 11, 71, 47, 149+  ,43, 127, 139, 199, 103,  7, 67, 79, 163+  ,37, 151, 139, 211, 109,  7, 79, 67, 181+  ,43, 181, 157, 241, 127, 13, 97, 73, 211]
Music/Theory/Math/Prime.hs view
@@ -5,25 +5,28 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import qualified Data.Numbers.Primes as P {- primes -}+import qualified Data.Numbers.Primes as Primes {- 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 -}+import qualified Music.Theory.Function as Function {- hmt -}+import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Math as Math {- hmt -}+import qualified Music.Theory.Unicode as Unicode {- hmt -} --- | Alias for 'P.primes'.+-- | Alias for 'Primes.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+primes_list = Primes.primes --- | Give zero-index of prime.+-- | Give zero-index of prime, or Nothing if value is not 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 i = if Primes.isPrime i then Just (List.findIndex_err (== i) primes_list) else Nothing +-- | 'maybe' 'error' of 'prime_k'+-- -- > prime_k_err 13 == 5 prime_k_err :: Integral a => a -> Int prime_k_err = fromMaybe (error "prime_k: not prime?") . prime_k@@ -31,17 +34,17 @@ {- | Generate list of factors of /n/ from /x/.  > factor primes_list 315 == [3,3,5,7]-> P.primeFactors 315 == [3,3,5,7]+> Primes.primeFactors 315 == [3,3,5,7]  As a special case 1 gives the empty list.  > factor primes_list 1 == []-> P.primeFactors 1 == []+> Primes.primeFactors 1 == [] -} factor :: Integral i => [i] -> i -> [i] factor x n =     case x of-      [] -> undefined+      [] -> error "factor: null primes_list input"       i:x' -> if n < i               then [] -- ie. prime factors of 1...               else if i * i > n@@ -54,9 +57,9 @@ -- -- > 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]]+-- > map Primes.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+prime_factors = factor primes_list  -- | 'maximum' of 'prime_factors' --@@ -69,7 +72,7 @@ -- -- > 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+multiplicities = List.generic_histogram_by (==) Nothing  -- | Pretty printer for histogram (multiplicites). --@@ -79,12 +82,12 @@   let f (x,y) = show x ++ "×" ++ show y   in unwords . map f --- | 'multiplicities' of 'P.primeFactors'.+-- | 'multiplicities' of 'Primes.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+prime_factors_m = multiplicities . Primes.primeFactors  -- | 'multiplicities_pp' of 'prime_factors_m'. prime_factors_m_pp :: (Show i,Integral i) => i -> String@@ -92,11 +95,11 @@  -- | Prime factors of /n/ and /d/. rat_prime_factors :: Integral i => (i,i) -> ([i],[i])-rat_prime_factors = T.bimap1 P.primeFactors+rat_prime_factors = Function.bimap1 Primes.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+rational_prime_factors = rat_prime_factors . Math.rational_nd  {- | Variant that writes factors of numerator as positive and factors for denominator as negative.      Sorted by absolute value.@@ -109,18 +112,20 @@ 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 (2 * 2 * 2 * 1/3 * 1/3 * 1/3 * 1/3 * 5) == [2,2,2,-3,-3,-3,-3,5] rational_prime_factors_sgn :: Integral i => Ratio i -> [i]-rational_prime_factors_sgn = rat_prime_factors_sgn . T.rational_nd+rational_prime_factors_sgn = rat_prime_factors_sgn . Math.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+rat_prime_limit = uncurry max . Function.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+rational_prime_limit = rat_prime_limit . Math.rational_nd  -- | Merge function for 'rat_prime_factors_m' rat_pf_merge :: Ord t => [(t,Int)] -> [(t,Int)] -> [(t,Int)]@@ -149,15 +154,16 @@ > 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 (5,31) == [(5,1),(31,-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+rational_prime_factors_m = rat_prime_factors_m . Math.rational_nd --- | Variant of 'rational_prime_factors_m' giving results in a list.+-- | Variant of 'rat_prime_factors_m' giving results in a list. -- -- > rat_prime_factors_l (1,1) == [] -- > rat_prime_factors_l (2^5,9) == [5,-2]@@ -168,22 +174,61 @@   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)+         in map (\i -> fromMaybe 0 (lookup i r)) (List.take_until (== lm) primes_list)  -- | 'Ratio' variant of 'rat_prime_factors_l' ----- > rational_prime_factors_l (256/243) == [8,-5]+-- > map rational_prime_factors_l [1/31,256/243] == [[0,0,0,0,0,0,0,0,0,0,-1],[8,-5]] rational_prime_factors_l :: Integral i => Ratio i -> [Int]-rational_prime_factors_l = rat_prime_factors_l . T.rational_nd+rational_prime_factors_l = rat_prime_factors_l . Math.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]+-- > map (rat_prime_factors_t 6) [(5,13),(12,7)] == [[0,0,1,0,0,-1],[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+rat_prime_factors_t k = List.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+rational_prime_factors_t n = rat_prime_factors_t n . Math.rational_nd++-- | Condense factors list to include only indicated places.+--   It is an error if a deleted factor has a non-zero entry in the table.+--+-- > rat_prime_factors_l (12,7) == [2,1,0,-1]+-- > rat_prime_factors_c [2,3,5,7] (12,7) == [2,1,0,-1]+-- > rat_prime_factors_c [2,3,7] (12,7) == [2,1,-1]+rat_prime_factors_c :: (Integral i,Show i) => [i] -> (i,i) -> [Int]+rat_prime_factors_c fc r =+  let t = rat_prime_factors_l r+      k = map prime_k_err fc+      f (ix,e) = if ix `notElem` k+                 then (if e > 0 then error "rat_prime_factors_c: non-empty factor" else Nothing)+                 else Just e+  in mapMaybe f (zip [0..] t)++-- | 'Ratio' variant of 'rat_prime_factors_t'+--+-- > map (rational_prime_factors_c [3,5,31]) [3,5,31]+rational_prime_factors_c :: (Integral i,Show i) => [i] -> Ratio i -> [Int]+rational_prime_factors_c fc = rat_prime_factors_c fc . Math.rational_nd++-- | Pretty printer for prime factors.  sup=superscript ol=overline+prime_factors_pp :: [Integer] -> String+prime_factors_pp = intercalate [Unicode.middle_dot] . map show++{- | Pretty printer for prime factors.  sup=superscript ol=overline++> prime_factors_pp_sup_ol True [2,2,-3,5] == "2²·3̅·5"+> prime_factors_pp_sup_ol False [-2,-2,-2,3,3,5,5,5,5] == "-2³·3²·5⁴"+-}+prime_factors_pp_sup_ol :: Bool -> [Integer] -> String+prime_factors_pp_sup_ol ol =+  let mk x = if x < 0 && ol then Unicode.overline (show (- x)) else show x+      f x = let x0 = head x+                n = length x+            in if n == 1 then mk x0 else mk x0 ++ Unicode.int_show_superscript n+  in intercalate [Unicode.middle_dot] . map f . group+
− Music/Theory/Maybe.hs 
@@ -1,78 +0,0 @@--- | Extensions to "Data.Maybe".-module Music.Theory.Maybe where--import Data.Maybe {- base -}---- | Variant with error text.-from_just :: String -> Maybe a -> a-from_just err = fromMaybe (error err)---- | Variant of unzip.------ > let r = ([Just 1,Nothing,Just 3],[Just 'a',Nothing,Just 'c'])--- > in maybe_unzip [Just (1,'a'),Nothing,Just (3,'c')] == r-maybe_unzip :: [Maybe (a,b)] -> ([Maybe a],[Maybe b])-maybe_unzip =-    let f x = case x of-                Nothing -> (Nothing,Nothing)-                Just (i,j) -> (Just i,Just j)-    in unzip . map f---- | Replace 'Nothing' elements with last 'Just' value.  This does not--- alter the length of the list.------ > maybe_latch 1 [Nothing,Just 2,Nothing,Just 4] == [1,2,2,4]-maybe_latch :: a -> [Maybe a] -> [a]-maybe_latch i x =-    case x of-      [] -> []-      Just e:x' -> e : maybe_latch e x'-      Nothing:x' -> i : maybe_latch i x'---- | Variant requiring initial value is not 'Nothing'.------ > maybe_latch1 [Just 1,Nothing,Nothing,Just 4] == [1,1,1,4]-maybe_latch1 :: [Maybe a] -> [a]-maybe_latch1 = maybe_latch (error "maybe_latch1")---- | 'map' of 'fmap'.------ > maybe_map negate [Nothing,Just 2] == [Nothing,Just (-2)]-maybe_map :: (a -> b) -> [Maybe a] -> [Maybe b]-maybe_map = map . fmap---- | If either is 'Nothing' then 'False', else /eq/ of values.-maybe_eq_by :: (t -> u -> Bool) -> Maybe t -> Maybe u -> Bool-maybe_eq_by eq_fn p q =-    case (p,q) of-      (Just p',Just q') -> eq_fn p' q'-      _ -> False---- | Join two values, either of which may be missing.-maybe_join' :: (s -> t) -> (s -> s -> t) -> Maybe s -> Maybe s -> Maybe t-maybe_join' f g p q =-    case (p,q) of-      (Nothing,_) -> fmap f q-      (_,Nothing) -> fmap f p-      (Just p',Just q') -> Just (p' `g` q')---- | 'maybe_join'' of 'id'-maybe_join :: (t -> t -> t) -> Maybe t -> Maybe t -> Maybe t-maybe_join = maybe_join' id---- | Apply predicate inside 'Maybe'.------ > maybe_predicate even (Just 3) == Nothing-maybe_predicate :: (a -> Bool) -> Maybe a -> Maybe a-maybe_predicate f i =-    case i of-      Nothing -> Nothing-      Just j -> if f j then Just j else Nothing---- | 'map' of 'maybe_predicate'.------ > let r = [Nothing,Nothing,Nothing,Just 4]--- > in maybe_filter even [Just 1,Nothing,Nothing,Just 4] == r-maybe_filter :: (a -> Bool) -> [Maybe a] -> [Maybe a]-maybe_filter = map . maybe_predicate-
Music/Theory/Meter/Barlow_1987.hs view
@@ -8,7 +8,7 @@  import qualified Data.Numbers.Primes as P {- primes -} -import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Math as T {- hmt-base -}  traceShow :: a -> b -> b traceShow _ x = x
Music/Theory/Metric/Polansky_1996.hs view
@@ -6,8 +6,9 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} +import qualified Music.Theory.List as L {- hmt-base -}+ 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)
− Music/Theory/Monad.hs 
@@ -1,22 +0,0 @@--- | Monad functions.-module Music.Theory.Monad where---- | 'sequence_' of 'repeat'.-repeatM_ :: Monad m => m a -> m ()-repeatM_ = sequence_ . repeat---- | Monadic variant of 'iterate'.-iterateM_ :: Monad m => (st -> m st) -> st -> m ()-iterateM_ f st = do-  st' <- f st-  iterateM_ f st'---- | 'fmap' of 'concat' of 'mapM'-concatMapM :: Monad m => (t -> m [u]) -> [t] -> m [u]-concatMapM f = fmap concat . mapM f---- | If i then j else k.-m_if :: Monad m => (m Bool,m t,m t) -> m t-m_if (i,j,k) = do-  r <- i-  if r then j else k
− Music/Theory/Opt.hs 
@@ -1,146 +0,0 @@-{- | Very simple CLI option parser.--Only allows options of the form --key=value, with the form --key equal to --key=True.--A list of OPT_USR describes the options and provides default values.--'get_opt_arg' merges user and default values into a table with values for all options.--To fetch options use 'opt_get' and 'opt_read'.---}-module Music.Theory.Opt where--import Control.Monad {- base -}-import Data.Either {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}-import System.Environment {- base -}-import System.Exit {- base -}--import qualified Data.List.Split as Split {- split -}--import qualified Music.Theory.Read as T {- hmt -}---- | (KEY,VALUE)---   Key does not include leading '--'.-type OPT = (String,String)---- | (KEY,DEFAULT-VALUE,TYPE,NOTE)-type OPT_USR = (String,String,String,String)---- | Re-write default values at USR_OPT.-opt_usr_rw_def :: [OPT] -> [OPT_USR] -> [OPT_USR]-opt_usr_rw_def rw =-  let f (k,v,ty,dsc) = case lookup k rw of-                         Just v' -> (k,v',ty,dsc)-                         Nothing -> (k,v,ty,dsc)-  in map f---- | OPT_USR to OPT.-opt_plain :: OPT_USR -> OPT-opt_plain (k,v,_,_) = (k,v)---- | OPT_USR to help string, indent is two spaces.-opt_usr_help :: OPT_USR -> String-opt_usr_help (k,v,t,n) = concat ["  ",k,":",t," -- ",n,"; default=",v]---- | 'unlines' of 'opt_usr_help'-opt_help :: [OPT_USR] -> String-opt_help = unlines . map opt_usr_help---- | Lookup KEY in OPT, error if non-existing.-opt_get :: [OPT] -> String -> String-opt_get o k = fromMaybe (error ("opt_get: " ++ k)) (lookup k o)---- | Variant that returns Nothing if the result is the empty string, else Just the result.-opt_get_nil :: [OPT] -> String -> Maybe String-opt_get_nil o k = let r = opt_get o k in if null r then Nothing else Just r---- | 'read' of 'get_opt'-opt_read :: Read t => [OPT] -> String -> t-opt_read o = T.read_err . opt_get o---- | Parse k or k=v string, else error.-opt_param_parse :: String -> OPT-opt_param_parse p =-  case Split.splitOn "=" p of-    [lhs] -> (lhs,"True")-    [lhs,rhs] -> (lhs,rhs)-    _ -> error ("opt_param_parse: " ++ p)---- | Parse option string of form "--opt" or "--key=value".------ > opt_parse "--opt" == Just ("opt","True")--- > opt_parse "--key=value" == Just ("key","value")-opt_parse :: String -> Maybe OPT-opt_parse s =-  case s of-    '-':'-':p -> Just (opt_param_parse p)-    _ -> Nothing---- | Parse option sequence, collating options and non-options.------ > opt_set_parse (words "--a --b=c d") == ([("a","True"),("b","c")],["d"])-opt_set_parse :: [String] -> ([OPT],[String])-opt_set_parse =-  let f s = maybe (Right s) Left (opt_parse s)-  in partitionEithers . map f---- | Left-biased OPT merge.-opt_merge :: [OPT] -> [OPT] -> [OPT]-opt_merge p q =-  let x = map fst p-  in p ++ filter (\(k,_) -> k `notElem` x) q---- | Process argument list.-opt_proc :: [OPT_USR] -> [String] -> ([OPT], [String])-opt_proc def arg =-  let (o,a) = opt_set_parse arg-  in (opt_merge o (map opt_plain def),a)---- | Usage text-type OPT_USG = [String]---- | Print usage pre-amble and 'opt_help'.-opt_usage :: OPT_USG -> [OPT_USR] -> IO ()-opt_usage usg def = putStrLn (unlines (usg ++ ["",opt_help def])) >> exitWith ExitSuccess---- | Verify that all OPT have keys that are in OPT_USR-opt_verify :: OPT_USG -> [OPT_USR] -> [OPT] -> IO ()-opt_verify usg def =-  let k_set = map (fst . opt_plain) def-      f (k,_) = if k `elem` k_set-                then return ()-                else putStrLn ("UNKNOWN KEY: " ++ k ++ "\n") >> opt_usage usg def-  in mapM_ f---- | 'opt_set_parse' and maybe 'opt_verify' and 'opt_merge' of 'getArgs'.---   If arguments include -h or --help run 'opt_usage'-opt_get_arg :: Bool -> OPT_USG -> [OPT_USR] -> IO ([OPT],[String])-opt_get_arg chk usg def = do-  a <- getArgs-  when ("-h" `elem` a || "--help" `elem` a) (opt_usage usg def)-  let (o,p) = opt_set_parse a-  when chk (opt_verify usg def o)-  return (opt_merge o (map opt_plain def),p)---- | Parse param set, one parameter per line.------ > opt_param_set_parse "a\nb=c" == [("a","True"),("b","c")]-opt_param_set_parse :: String -> [OPT]-opt_param_set_parse = map opt_param_parse . lines---- | Simple scanner over argument list.-opt_scan :: [String] -> String -> Maybe String-opt_scan a k =-  let (o,_) = opt_set_parse a-  in fmap snd (find ((== k) . fst) o)---- | Scanner with default value.-opt_scan_def :: [String] -> (String,String) -> String-opt_scan_def a (k,v) = fromMaybe v (opt_scan a k)---- | Reading scanner with default value.-opt_scan_read :: Read t => [String] -> (String,t) -> t-opt_scan_read a (k,v) = maybe v read (opt_scan a k)
− Music/Theory/Ord.hs 
@@ -1,42 +0,0 @@--- | '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---- | Specialised 'toEnum'.-int_to_ord :: Int -> Ordering-int_to_ord = toEnum---- | Invert 'Ordering'.------ > map ord_invert [LT,EQ,GT] == [GT,EQ,LT]-ord_invert :: Ordering -> Ordering-ord_invert x =-    case x of-      LT -> GT-      EQ -> EQ-      GT -> LT---- | Given 'Ordering', re-order pair,-order_pair :: Ordering -> (t,t) -> (t,t)-order_pair o (x,y) =-    case o of-      LT -> (x,y)-      EQ -> (x,y)-      GT -> (y,x)---- | Sort a pair of equal type values using given comparison function.------ > sort_pair compare ('b','a') == ('a','b')-sort_pair :: (t -> t -> Ordering) -> (t,t) -> (t,t)-sort_pair fn (x,y) = order_pair (fn x y) (x,y)---- | Variant where the comparison function may not compute a value.-sort_pair_m :: (t -> t -> Maybe Ordering) -> (t,t) -> Maybe (t,t)-sort_pair_m fn (x,y) = fmap (`order_pair` (x,y)) (fn x y)
Music/Theory/Parse.hs view
@@ -1,3 +1,4 @@+-- | Parsing utilities module Music.Theory.Parse where  import Data.Maybe {- base -}@@ -15,3 +16,12 @@ -- | Parse 'Integral'. parse_int :: Integral i => P i parse_int = fmap (fromInteger . read) (P.many1 P.digit)++run_parser :: P t -> String -> Either P.ParseError t+run_parser p = P.runParser p () ""++run_parser_maybe :: P t -> String -> Maybe t+run_parser_maybe p = either (const Nothing) Just . run_parser p++run_parser_error :: P c -> String -> c+run_parser_error p = either (error . show) id . run_parser p
− Music/Theory/Permutations.hs 
@@ -1,162 +0,0 @@--- | Permutation functions.-module Music.Theory.Permutations where--import qualified Data.Permute as P {- permutation -}-import qualified Numeric {- base -}--import qualified Music.Theory.List as L {- hmt -}---- | Factorial function.------ > (factorial 13,maxBound::Int)-factorial :: (Ord a, Num a) => a -> a-factorial n = if n <= 1 then 1 else n * factorial (n - 1)---- | Number of /k/ element permutations of a set of /n/ elements.------ > 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---- | Generate the permutation from /p/ to /q/, ie. the permutation--- that, when applied to /p/, gives /q/.------ > apply_permutation (permutation "abc" "bac") "abc" == "bac"-permutation :: (Eq a) => [a] -> [a] -> P.Permute-permutation p q =-    let n = length p-        f x = L.elem_index_unique x p-    in P.listPermute n (map f q)---- | Apply permutation /f/ to /p/.------ > let p = permutation [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)---- | Composition of 'apply_permutation' and 'from_cycles'.------ > apply_permutation_c [[0,3],[1,2]] [1..4] == [4,3,2,1]--- > apply_permutation_c [[0,2],[1],[3,4]] [1..5] == [3,2,1,5,4]--- > apply_permutation_c [[0,1,4],[2,3]] [1..5] == [2,5,4,3,1]--- > apply_permutation_c [[0,1,3],[2,4]] [1..5] == [2,4,5,1,3]-apply_permutation_c :: [[Int]] -> [a] -> [a]-apply_permutation_c = apply_permutation . from_cycles---- | True if the inverse of /p/ is /p/.------ > non_invertible (permutation [0,1,3] [1,0,3]) == True------ > let p = permutation [1..4] [4,3,2,1]--- > non_invertible p == True && P.cycles p == [[0,3],[1,2]]-non_invertible :: P.Permute -> Bool-non_invertible p = p == P.inverse p---- | Generate a permutation from the cycles /c/.------ > apply_permutation (from_cycles [[0,1,2,3]]) [1..4] == [2,3,4,1]-from_cycles :: [[Int]] -> P.Permute-from_cycles c = P.cyclesPermute (sum (map length c)) c---- | Generate all permutations of size /n/.------ > 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-              in maybe [p] (\np -> p : f np) r-    in f (P.permute n)---- | Composition of /q/ then /p/.------ > 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-        i = [1 .. n]-        j = apply_permutation p i-        k = apply_permutation q j-    in permutation i k---- | Two line notation of /p/.------ > two_line (permutation [0,1,3] [1,0,3]) == ([1,2,3],[2,1,3])-two_line :: P.Permute -> ([Int],[Int])-two_line p =-    let n = P.size p-        i = [1..n]-    in (i,apply_permutation p i)---- | One line notation of /p/.------ > one_line (permutation [0,1,3] [1,0,3]) == [2,1,3]------ > 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---- | Variant of 'one_line' that produces a compact string.------ > one_line_compact (permutation [0,1,3] [1,0,3]) == "213"------ > let p = permutations_n 3--- > 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 Numeric.showHex n ""-              else error "one_line_compact:not(0-15)"-    in concatMap f . one_line---- | Multiplication table of symmetric group /n/.------ > unlines (map (unwords . map one_line_compact) (multiplication_table 3))------ @--- ==> 123 132 213 231 312 321---     132 123 312 321 213 231---     213 231 123 132 321 312---     231 213 321 312 123 132---     312 321 132 123 231 213---     321 312 231 213 132 123--- @-multiplication_table :: Int -> [[P.Permute]]-multiplication_table n =-    let ps = permutations_n n-        f p = map (compose p) ps-    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])--let p = permutation [1..5] [3,2,1,5,4] -- [[0,2],[1],[3,4]]-let q = permutation [1..5] [2,5,4,3,1] -- [[0,1,4],[2,3]]-let r = permutation [1..5] [2,4,5,1,3] -- [[0,1,3],[2,4]]-(non_invertible p,P.cycles p,apply_permutation p [1..5])-(non_invertible q,P.cycles q,apply_permutation q [1..5])-(non_invertible r,P.cycles r,apply_permutation r [1..5])--map P.cycles (permutations_n 3)-map P.cycles (permutations_n 4)--import Data.List {- base -}-partition not (map non_invertible (permutations_n 4))-putStrLn $ unlines $ map unwords $ permutations ["A0","A1","B0"]---}
Music/Theory/Permutations/List.hs view
@@ -2,9 +2,10 @@ module Music.Theory.Permutations.List where  import Data.List {- base -}+ import qualified Math.Combinatorics.Multiset as C {- multiset-comb -} -import qualified Music.Theory.Permutations as P {- hmt -}+import qualified Music.Theory.Permutations as P {- hmt-base -}  -- | Generate all permutations. --@@ -15,25 +16,31 @@     let f p = P.apply_permutation p i     in map f (P.permutations_n (length i)) +-- | /k/-element permutations of a set of /n/-elements.+--+-- > permutations_nk_l 3 2 "abc" == ["ab","ac","ba","bc","ca","cb"]+permutations_nk_l :: Eq e => Int -> Int -> [e] -> [[e]]+permutations_nk_l n k e =+  if length e /= n+  then error "permutations_nk_l"+  else nub (map (take k) (permutations_l e))+ -- | Generate all distinct permutations of a multi-set. -- -- > multiset_permutations [0,1,1] == [[0,1,1],[1,1,0],[1,0,1]]-multiset_permutations :: (Ord a) => [a] -> [[a]]+multiset_permutations :: Ord a => [a] -> [[a]] multiset_permutations = C.permutations . C.fromList -factorial :: (Enum a, Num a) => a -> a-factorial n = product [1..n]- -- | Calculate number of permutations of a multiset. ----- > let r = factorial 11 `div` product (map factorial [1,4,4,2])--- > in multiset_permutations_n "MISSISSIPPI" == r+-- > let r = P.factorial 11 `div` product (map P.factorial [1,4,4,2])+-- > multiset_permutations_n "MISSISSIPPI" == r -- -- > multiset_permutations_n "MISSISSIPPI" == 34650 -- > length (multiset_permutations "MISSISSIPPI") == 34650 multiset_permutations_n :: Ord a => [a] -> Int multiset_permutations_n x =     let occ = map length . group . sort-        n = factorial (length x)-        d = product $ map factorial $ occ x+        n = P.factorial (length x)+        d = product $ map P.factorial $ occ x     in n `div` d
Music/Theory/Permutations/Morris_1984.hs view
@@ -9,28 +9,37 @@ import Data.List.Split {- split -} import Data.Maybe {- base -} -import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Permutations as T {- hmt -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Permutations as T {- hmt-base -}+import qualified Music.Theory.Tuple as T {- hmt-base -}  -- | A change either swaps all adjacent bells, or holds a subset of bells. data Change = Swap_All | Hold [Int] deriving (Eq,Show) --- | A method is a sequence of changes, if symmetrical only have the+-- | A method is a sequence of changes, if symmetrical only half the -- changes are given and the lead end.-data Method = Method [Change] (Maybe Change) deriving (Eq,Show)+data Method = Method [Change] (Maybe [Change]) deriving (Eq,Show) --- | Compete list of 'Change's at 'Method', writing out symmetries.+-- | Maximum hold value at 'Method'+method_limit :: Method -> Int+method_limit (Method p q) =+  let f c = case c of+              Swap_All -> 0+              Hold i -> maximum i+  in maximum (map f (p ++ fromMaybe [] q))++-- | Complete list of 'Change's at 'Method', writing out symmetries. method_changes :: Method -> [Change] method_changes (Method p q) =     case q of       Nothing -> p-      Just q' -> p ++ tail (reverse p) ++ [q']+      Just le -> p ++ tail (reverse p) ++ le  -- | Parse a change notation. -- -- > map parse_change ["-","x","38"] == [Swap_All,Swap_All,Hold [3,8]] parse_change :: String -> Change-parse_change s = if is_swap_all s then Swap_All else Hold (to_abbrev s)+parse_change s = if is_swap_all s then Swap_All else Hold (map nchar_to_int s)  -- | Separate changes. --@@ -39,58 +48,64 @@ split_changes :: String -> [String] split_changes = filter (/= ".") . split (dropInitBlank (oneOf "-x.")) --- | Parse 'Method' from the sequence of changes with possible lead end.------ > parse_method ("-38-14-1258-36-14-58-16-78",Just "12")-parse_method :: (String,Maybe String) -> Method+-- | Place notation, sequence of changes with possible lead end.+type Place = (String,Maybe String)++-- | Parse 'Method' given 'PLACE' notation.+parse_method :: Place -> Method parse_method (p,q) =-    let c = map parse_change (split_changes p)-        le = fmap parse_change q-    in Method c le+    let f = map parse_change . split_changes+    in Method (f p) (fmap f q) --- > map is_swap_all ["-","x","38"] == [True,True,False]-is_swap_all :: String -> Bool-is_swap_all s =-    case s of-      [c] -> c `elem` "-x"-      _ -> False+-- | Parse string into 'Place'.+--+-- > parse_method (parse_place "-38-14-1258-36-14-58-16-78,12")+parse_place :: String -> Place+parse_place txt =+  case splitOn "," txt of+    [p] -> (p,Nothing)+    [p,q] -> (p,Just q)+    _ -> error "parse_place?" --- | Swap elemets of two-tuple (pair).+-- | - or x? ----- > swap_pair (1,2) == (2,1)-swap_pair :: (s,t) -> (t,s)-swap_pair (p,q) = (q,p)+-- > map is_swap_all ["-","x","38"] == [True,True,False]+is_swap_all :: String -> Bool+is_swap_all = flip elem ["-","x"]  -- | Flatten list of pairs. -- -- > flatten_pairs [(1,2),(3,4)] == [1..4] flatten_pairs :: [(a,a)] -> [a]-flatten_pairs l =-    case l of-      [] -> []-      (p,q):l' -> p : q : flatten_pairs l'+flatten_pairs = concatMap T.t2_to_list  -- | Swap all adjacent pairs at list. -- -- > swap_all [1 .. 8] == [2,1,4,3,6,5,8,7] swap_all :: [a] -> [a]-swap_all = flatten_pairs . map swap_pair . T.adj2 2+swap_all = flatten_pairs . map T.p2_swap . T.adj2 2  numeric_spelling_tbl :: [(Char,Int)]-numeric_spelling_tbl = zip "1234567890ETABCD" [1 .. 16]+numeric_spelling_tbl = zip "1234567890ETABCDFGHJKL" [1 .. 22] --- | Parse abbreviated 'Hold' notation, characters are hexedecimal.+-- | Parse abbreviated 'Hold' notation, characters are NOT hexadecimal. ----- > to_abbrev "380ETA" == [3,8,10,11,12,13]-to_abbrev :: String -> [Int]-to_abbrev = map (fromMaybe (error "to_abbrev") . flip lookup numeric_spelling_tbl)+-- > map nchar_to_int "380ETA" == [3,8,10,11,12,13]+nchar_to_int :: Char -> Int+nchar_to_int = fromMaybe (error "nchar_to_int") . flip lookup numeric_spelling_tbl +-- | Inverse of 'nchar_to_int'.+--+-- > map int_to_nchar [3,8,10,11,12,13] == "380ETA"+int_to_nchar :: Int -> Char+int_to_nchar = flip T.reverse_lookup_err numeric_spelling_tbl+ -- | Given a 'Hold' notation, generate permutation cycles. -- -- > let r = [Right (1,2),Left 3,Right (4,5),Right (6,7),Left 8]--- > in gen_swaps 8 [3,8] == r+-- > gen_swaps 8 [3,8] == r ----- > let r = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)]+-- > r = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)] -- > gen_swaps 8 [1,2] == r gen_swaps :: (Num t, Ord t) => t -> [t] -> [Either t (t,t)] gen_swaps k =@@ -124,7 +139,7 @@ -- | One-indexed permutation cycles to zero-indexed. -- -- > let r = [[0],[1],[2,3],[4,5],[6,7]]--- > in to_zero_indexed [[1],[2],[3,4],[5,6],[7,8]] == r+-- > to_zero_indexed [[1],[2],[3,4],[5,6],[7,8]] == r to_zero_indexed :: Enum t => [[t]] -> [[t]] to_zero_indexed = map (map pred) @@ -134,7 +149,7 @@ swap_abbrev :: Int -> [Int] -> [a] -> [a] swap_abbrev k a =     let c = to_zero_indexed (swaps_to_cycles (gen_swaps k a))-        p = T.from_cycles c+        p = T.from_cycles_zero_indexed c     in T.apply_permutation p  -- | Apply a 'Change'.@@ -150,7 +165,7 @@ -- > let r = ([1,2,4,5,3] -- >         ,[[1,2,3,4,5],[2,1,3,4,5],[2,3,1,4,5],[3,2,4,1,5],[3,4,2,5,1] -- >          ,[4,3,2,5,1],[4,2,3,1,5],[2,4,1,3,5],[2,1,4,3,5],[1,2,4,3,5]])--- > in apply_method cambridgeshire_slow_course_doubles [1..5] == r+-- > apply_method cambridgeshire_slow_course_doubles [1..5] == r apply_method :: Method -> [a] -> ([a],[[a]]) apply_method m l =     let k = length l@@ -171,60 +186,69 @@     in rec l []  -- | 'concat' of 'closed_method' with initial sequence appended.-closed_method' :: Eq a => Method -> [a] -> [[a]]-closed_method' m l = concat (closed_method m l) ++ [l]+closed_method_lp :: Eq a => Method -> [a] -> [[a]]+closed_method_lp m l = concat (closed_method m l) ++ [l] +-- | 'closed_method' of 'parse_method'+closed_place :: Eq t => Place -> [t] -> [[[t]]]+closed_place pl = closed_method (parse_method pl)+ -- * Methods --- | <https://rsw.me.uk/blueline/methods/view/Cambridgeshire_Slow_Course_Doubles>+-- | <https://rsw.me.uk/blueline/methods/view/Cambridgeshire_Place_Doubles> ----- > length (closed_method cambridgeshire_slow_course_doubles [1..5]) == 3+-- > length (closed_place cambridgeshire_place_doubles_pl [1..5]) == 3+cambridgeshire_place_doubles_pl :: Place+cambridgeshire_place_doubles_pl = ("345.145.5.1.345",Just "123")++-- | 'parse_method' of 'cambridgeshire_place_doubles_pl' cambridgeshire_slow_course_doubles :: Method-cambridgeshire_slow_course_doubles =-    let a = ("345.145.5.1.345",Just "123")-    in parse_method a+cambridgeshire_slow_course_doubles = parse_method cambridgeshire_place_doubles_pl --- | Double Cambridge Cyclic Bob Minor.------ <https://rsw.me.uk/blueline/methods/view/Double_Cambridge_Cyclic_Bob_Minor>+-- | <https://rsw.me.uk/blueline/methods/view/Double_Cambridge_Cyclic_Bob_Minor> ----- > length (closed_method double_cambridge_cyclic_bob_minor [1..6]) == 5+-- > length (closed_place double_cambridge_cyclic_bob_minor_pl [1..6]) == 5+double_cambridge_cyclic_bob_minor_pl :: Place+double_cambridge_cyclic_bob_minor_pl = ("-14-16-56-36-16-12",Nothing)++-- | 'parse_method' of 'double_cambridge_cyclic_bob_minor_pl' double_cambridge_cyclic_bob_minor :: Method-double_cambridge_cyclic_bob_minor =-    let a = ("-14-16-56-36-16-12",Nothing)-    in parse_method a+double_cambridge_cyclic_bob_minor = parse_method double_cambridge_cyclic_bob_minor_pl --- | Hammersmith Bob Triples------ <https://rsw.me.uk/blueline/methods/view/Hammersmith_Bob_Triples>+-- | <https://rsw.me.uk/blueline/methods/view/Hammersmith_Bob_Triples> ----- > length (closed_method hammersmith_bob_triples [1..7]) == 6+-- > length (closed_place hammersmith_bob_triples_pl [1..7]) == 6+hammersmith_bob_triples_pl :: Place+hammersmith_bob_triples_pl = ("7.1.5.123.7.345.7",Just "127")+ hammersmith_bob_triples :: Method-hammersmith_bob_triples =-    let a = ("7.1.5.123.7.345.7",Just "127")-    in parse_method a+hammersmith_bob_triples = parse_method hammersmith_bob_triples_pl  -- | <https://rsw.me.uk/blueline/methods/view/Cambridge_Surprise_Major> ----- > length (closed_method cambridge_surprise_major [1..8]) == 7+-- > length (closed_place cambridge_surprise_major_pl [1..8]) == 7+cambridge_surprise_major_pl :: Place+cambridge_surprise_major_pl = ("-38-14-1258-36-14-58-16-78",Just "12")+ cambridge_surprise_major :: Method-cambridge_surprise_major =-    let a = ("-38-14-1258-36-14-58-16-78",Just "12")-    in parse_method a+cambridge_surprise_major = parse_method cambridge_surprise_major_pl  -- | <https://rsw.me.uk/blueline/methods/view/Smithsonian_Surprise_Royal> ----- > let m = closed_method smithsonian_surprise_royal [1..10]--- > (length m,nub (map length m),sum (map length m)) == (9,[40],360)+-- > let c = closed_place smithsonian_surprise_royal_pl [1..10]+-- > (length c,nub (map length c),sum (map length c)) == (9,[40],360)+smithsonian_surprise_royal_pl :: Place+smithsonian_surprise_royal_pl = ("-30-14-50-16-3470-18-1456-50-16-70",Just "12")+ smithsonian_surprise_royal :: Method-smithsonian_surprise_royal =-    let a = ("-30-14-50-16-3470-18-1456-50-16-70",Just "12")-    in parse_method a+smithsonian_surprise_royal = parse_method smithsonian_surprise_royal_pl  -- | <https://rsw.me.uk/blueline/methods/view/Ecumenical_Surprise_Maximus> ----- > let m = closed_method ecumenical_surprise_maximus [1..12]--- > (length m,nub (map length m),sum (map length m)) == (11,[48],528)+-- > c = closed_place ecumenical_surprise_maximus_pl [1..12]+-- > (length c,nub (map length c),sum (map length c)) == (11,[48],528)+ecumenical_surprise_maximus_pl :: Place+ecumenical_surprise_maximus_pl = ("x3Tx14x5Tx16x7Tx1238x149Tx50x16x7Tx18.90.ET",Just "12")+ ecumenical_surprise_maximus :: Method-ecumenical_surprise_maximus =-  parse_method ("x3Tx14x5Tx16x7Tx1238x149Tx50x16x7Tx18.90.ET",Just "12")+ecumenical_surprise_maximus = parse_method ecumenical_surprise_maximus_pl
Music/Theory/Pitch.hs view
@@ -5,14 +5,14 @@ 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.Math.Convert as T {- hmt -}+import qualified Music.Theory.Parse 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 -}@@ -50,61 +50,78 @@ midi_to_octave_pitchclass :: (Integral m,Integral i) => m -> Octave_PitchClass i midi_to_octave_pitchclass n = (fromIntegral n - 12) `divMod` 12 +{- | One-indexed piano key number (for standard 88 key piano) to pitch class.+     This has the mnemonic that 49 maps to (4,9).++> map pianokey_to_octave_pitchclass [1,49,88] == [(0,9),(4,9),(8,0)]+-}+pianokey_to_octave_pitchclass :: (Integral m,Integral i) => m -> Octave_PitchClass i+pianokey_to_octave_pitchclass = midi_to_octave_pitchclass . (+) 20+ -- * Octave & PitchClass --- | Pitch classes are modulo twelve integers.+-- | Pitch classes are modulo twelve integers (0-11) type PitchClass = Int  -- | Octaves are integers, the octave of middle C is @4@. type Octave = Int  -- | 'Octave' and 'PitchClass' duple.-type OctPC = (Octave,PitchClass)+type OctPc = (Octave,PitchClass)  -- | Translate from generic octave & pitch-class duple.-octave_pitchclass_to_octpc :: (Integral pc, Integral oct) => (oct,pc) -> OctPC+octave_pitchclass_to_octpc :: (Integral pc, Integral oct) => (oct,pc) -> OctPc octave_pitchclass_to_octpc (oct,pc) = (fromIntegral oct,fromIntegral pc) --- | Normalise 'OctPC'.+-- | Normalise 'OctPc'. -- -- > octpc_nrm (4,16) == (5,4)-octpc_nrm :: OctPC -> OctPC+octpc_nrm :: OctPc -> OctPc octpc_nrm = octave_pitchclass_nrm --- | Transpose 'OctPC'.+-- | Transpose 'OctPc'. -- -- > octpc_trs 7 (4,9) == (5,4) -- > octpc_trs (-11) (4,9) == (3,10)-octpc_trs :: Int -> OctPC -> OctPC+octpc_trs :: Int -> OctPc -> OctPc octpc_trs = octave_pitchclass_trs  -- | Enumerate range, inclusive. -- -- > octpc_range ((3,8),(4,1)) == [(3,8),(3,9),(3,10),(3,11),(4,0),(4,1)]-octpc_range :: (OctPC,OctPC) -> [OctPC]+octpc_range :: (OctPc,OctPc) -> [OctPc] octpc_range (l,r) =     let (l',r') = (octpc_to_midi l,octpc_to_midi r)     in map midi_to_octpc [l' .. r']  -- * Midi note number (0 - 127) --- | Midi note number-type Midi = Word8+{- | Midi note number (0 - 127).+     Midi data values are unsigned 7-bit integers, however using an unsigned type would be problematic.+     It would make transposition, for instance, awkward.+     x - 12 would transpose down an octave, but the transposition interval itself could not be negative.+-}+type Midi = Int +-- | Type conversion midi_to_int :: Midi -> Int-midi_to_int = fromIntegral+midi_to_int = id --- | 'OctPC' value to integral /midi/ note number.+-- | Type-specialise /f/, ie. round, ceiling, truncate+double_to_midi :: (Double -> Midi) -> Double -> Midi+double_to_midi = T.double_to_int++-- | 'OctPc' value to integral /midi/ note number. -- -- > 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 = fromIntegral . octave_pitchclass_to_midi+octpc_to_midi :: OctPc -> Midi+octpc_to_midi = octave_pitchclass_to_midi  -- | Inverse of 'octpc_to_midi'. -- -- > map midi_to_octpc [40,69] == [(2,4),(4,9)]-midi_to_octpc :: Midi -> OctPC+midi_to_octpc :: Midi -> OctPc midi_to_octpc = midi_to_octave_pitchclass  -- * Octave & fractional pitch-class@@ -135,7 +152,7 @@ type FMidi = Double  -- | Fractional octave pitch-class (octave is integral, pitch-class is fractional).-type FOctPC = (Int,Double)+type FOctPc = (Int,Double)  -- | 'fromIntegral' of 'octpc_to_midi'. octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n@@ -174,8 +191,8 @@ -- * Pitch  -- | Common music notation pitch value.-data Pitch = Pitch {note :: T.Note_T-                   ,alteration :: T.Alteration_T+data Pitch = Pitch {note :: T.Note+                   ,alteration :: T.Alteration                    ,octave :: Octave}            deriving (Eq,Show) @@ -239,12 +256,12 @@ -- * Spelling  -- | Function to spell a 'PitchClass'.-type Spelling n = n -> (T.Note_T,T.Alteration_T)+type Spelling n = n -> (T.Note,T.Alteration)  -- | Variant of 'Spelling' for incomplete functions.-type Spelling_M i = i -> Maybe (T.Note_T,T.Alteration_T)+type Spelling_M i = i -> Maybe (T.Note,T.Alteration) --- | Given 'Spelling' function translate from 'OctPC' notation to 'Pitch'.+-- | Given 'Spelling' function translate from 'OctPc' notation to 'Pitch'. -- -- > octpc_to_pitch T.pc_spell_sharp (4,6) == Pitch T.F T.Sharp 4 octpc_to_pitch :: Integral i => Spelling i -> Octave_PitchClass i -> Pitch@@ -260,9 +277,11 @@ midi_to_pitch :: (Integral i,Integral k) => Spelling k -> i -> Pitch midi_to_pitch sp = octpc_to_pitch sp . midi_to_octave_pitchclass --- | Fractional midi note number to 'Pitch'.------ > fmidi_to_pitch T.pc_spell_ks 69.25 == Nothing+{- | Fractional midi note number to 'Pitch'.++> p = Pitch T.B T.ThreeQuarterToneFlat 4+> map (fmidi_to_pitch T.pc_spell_ks) [69.25,69.5] == [Nothing,Just p]+-} fmidi_to_pitch :: RealFrac n => Spelling PitchClass -> n -> Maybe Pitch fmidi_to_pitch sp m =     let m' = T.real_round_int m@@ -286,9 +305,9 @@ -- -- > 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 =+-- > pitch_transpose_fmidi T.pc_spell_ks 2 T.ees5 == T.f5+pitch_transpose_fmidi :: (RealFrac n,Show n) => Spelling Int -> n -> Pitch -> Pitch+pitch_transpose_fmidi sp n p =     let m = pitch_to_fmidi p     in fmidi_to_pitch_err sp (m + n) @@ -369,7 +388,7 @@         o = fmidi_octave (fmidi_in_octave_nearest (f p1) (f p2))     in p2 {octave = o} --- | Raise 'Note_T' of 'Pitch', account for octave transposition.+-- | Raise 'Note' of 'Pitch', account for octave transposition. -- -- > pitch_note_raise (Pitch B Natural 3) == Pitch C Natural 4 pitch_note_raise :: Pitch -> Pitch@@ -378,7 +397,7 @@     then Pitch minBound a (o + 1)     else Pitch (succ n) a o --- | Lower 'Note_T' of 'Pitch', account for octave transposition.+-- | Lower 'Note' of 'Pitch', account for octave transposition. -- -- > pitch_note_lower (Pitch C Flat 4) == Pitch B Flat 3 pitch_note_lower :: Pitch -> Pitch@@ -408,25 +427,29 @@  -- * Frequency (CPS) +-- | 'fmidi_to_cps' of 'pitch_to_fmidi', given (k0,f0).+pitch_to_cps_k0 :: Floating n => (n,n) -> Pitch -> n+pitch_to_cps_k0 o = T.fmidi_to_cps_k0 o . pitch_to_fmidi+ -- | 'fmidi_to_cps' of 'pitch_to_fmidi', given frequency of ISO A4. pitch_to_cps_f0 :: Floating n => n -> Pitch -> n-pitch_to_cps_f0 f0 = T.fmidi_to_cps_f0 f0 . pitch_to_fmidi+pitch_to_cps_f0 f0 = pitch_to_cps_k0 (69,f0) --- | 'pitch_to_cps_f0' 440.+-- | 'pitch_to_cps_k0' (60,440). pitch_to_cps :: Floating n => Pitch -> n-pitch_to_cps = pitch_to_cps_f0 440+pitch_to_cps = pitch_to_cps_k0 (69,440)  -- | Frequency (cps = cycles per second) to fractional /midi/ note -- number, given frequency of ISO A4 (mnn = 69).-cps_to_fmidi_f0 :: Floating a => a -> a -> a-cps_to_fmidi_f0 f0 a = (logBase 2 (a * (1 / f0)) * 12) + 69+cps_to_fmidi_k0 :: Floating a => (a,a) -> a -> a+cps_to_fmidi_k0 (k0,f0) a = (logBase 2 (a * (1 / f0)) * 12) + k0 --- | 'cps_to_fmidi_f0' @440@.+-- | 'cps_to_fmidi_k0' @(69,440)@. -- -- > cps_to_fmidi 440 == 69 -- > cps_to_fmidi (fmidi_to_cps 60.25) == 60.25 cps_to_fmidi :: Floating a => a -> a-cps_to_fmidi = cps_to_fmidi_f0 440+cps_to_fmidi = cps_to_fmidi_k0 (69,440)  -- | Frequency (cycles per second) to /midi/ note number, -- ie. 'round' of 'cps_to_fmidi'.@@ -435,15 +458,16 @@ cps_to_midi :: (Integral i,Floating f,RealFrac f) => f -> i cps_to_midi = round . cps_to_fmidi --- | '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 = T.midi_to_cps_f0 f0 . octave_pitchclass_to_midi+-- | 'midi_to_cps_f0' of 'octpc_to_midi', given (k0,f0)+octpc_to_cps_k0 :: (Integral i,Floating n) => (n,n) -> Octave_PitchClass i -> n+octpc_to_cps_k0 o = T.midi_to_cps_k0 o . octave_pitchclass_to_midi --- | 'octpc_to_cps_f0' 440.------ > octpc_to_cps (4,9) == 440+{- | 'octpc_to_cps_k0' (69,440).++> map (round . octpc_to_cps) [(-1,0),(0,0),(4,9),(9,0)] == [8,16,440,8372]+-} octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n-octpc_to_cps = octpc_to_cps_f0 440+octpc_to_cps = octpc_to_cps_k0 (69,440)  -- | 'midi_to_octpc' of 'cps_to_midi'. cps_to_octpc :: (Floating f,RealFrac f,Integral i) => f -> Octave_PitchClass i@@ -575,7 +599,7 @@ -- * Pitch, rational alteration.  -- | Generalised pitch, given by a generalised alteration.-data Pitch_R = Pitch_R T.Note_T T.Alteration_R Octave+data Pitch_R = Pitch_R T.Note T.Alteration_R Octave                deriving (Eq,Show)  -- | Pretty printer for 'Pitch_R'.@@ -588,19 +612,39 @@  -- * Parsers +-- | Parser for single digit ISO octave (C4 = middle-C)+p_octave_iso :: T.P Octave+p_octave_iso = fmap digitToInt P.digit++-- | Parser for single digit ISO octave with default value in case of no parse.+p_octave_iso_opt :: Octave -> T.P Octave+p_octave_iso_opt def_o = do+  o <- P.optionMaybe p_octave_iso+  return (fromMaybe def_o o)++-- | Parser for ISO pitch notation.+p_iso_pitch_strict :: T.P Pitch+p_iso_pitch_strict = do+  n <- T.p_note_t+  a <- T.p_alteration_t_iso True+  o <- p_octave_iso+  return (Pitch  n a o)++-- | Parser for extended form of ISO pitch notation.+p_iso_pitch_oct :: Octave -> T.P Pitch+p_iso_pitch_oct def_o = do+  n <- T.p_note_t_ci -- ISO is requires upper case note names+  a <- T.p_alteration_t_iso False -- ISO does not allow ##+  o <- p_octave_iso_opt def_o -- ISO requires octave+  return (Pitch  n a o)+ -- | Parse possible octave from single integer. ----- > 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-      [] -> Just def_o-      [n] -> if isDigit n-             then Just (fromIntegral (digitToInt n))-             else Nothing-      _ -> Nothing+-- > map (parse_octave 2) ["","4","x","11"] == [2,4,2,1]x+parse_octave :: Octave -> String -> Octave+parse_octave def_o = T.run_parser_error (p_octave_iso_opt def_o) --- | Slight generalisation of ISO pitch representation.  Allows octave+-- | Generalisation of ISO pitch representation.  Allows octave -- to be elided, pitch names to be lower case, and double sharps -- written as @##@. --@@ -609,18 +653,7 @@ -- > 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-                   Nothing -> Nothing-                   Just n' -> fmap (Pitch n' a) (parse_octave def_o o)-    in case s of-         [] -> Nothing-         n:'b':'b':o -> mk n T.DoubleFlat o-         n:'#':'#':o -> mk n T.DoubleSharp o-         n:'x':o -> mk n T.DoubleSharp o-         n:'b':o -> mk n T.Flat o-         n:'#':o -> mk n T.Sharp o-         n:o -> mk n T.Natural o+parse_iso_pitch_oct def_o = T.run_parser_maybe (p_iso_pitch_oct def_o)  -- | Variant of 'parse_iso_pitch_oct' requiring octave. parse_iso_pitch :: String -> Maybe Pitch@@ -725,16 +758,13 @@  -- * Parsers -p_octave_iso :: P.GenParser Char () Octave-p_octave_iso = fmap digitToInt P.digit--p_octave_ly :: P.GenParser Char () Octave+p_octave_ly :: T.P Octave p_octave_ly =     fmap     (fromMaybe (error "p_octave_ly") . octave_parse_ly)     (P.many1 (P.oneOf ",'")) -p_pitch_ly :: P.GenParser Char () Pitch+p_pitch_ly :: T.P Pitch p_pitch_ly = do   (n,a) <- T.p_note_alteration_ly   o <- P.optionMaybe p_octave_ly@@ -744,23 +774,16 @@ -- -- > 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_parse_ly_err = T.run_parser_error p_pitch_ly  -- | Parser for hly notation.-p_pitch_hly :: P.GenParser Char () Pitch+p_pitch_hly :: T.P Pitch p_pitch_hly = do   (n,a) <- T.p_note_alteration_ly-  o <- p_octave_iso-  return (Pitch n (fromMaybe T.Natural a) o)+  fmap (Pitch n (fromMaybe T.Natural a)) p_octave_iso  -- | 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+pitch_parse_hly = T.run_parser_error p_pitch_hly
Music/Theory/Pitch/Chord.hs view
@@ -4,15 +4,15 @@ import Data.Maybe {- base -}  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 -}+import qualified Music.Theory.Parse as T {- hmt -} import qualified Music.Theory.Pitch.Note as T {- hmt -} -type PC = (T.Note_T,T.Alteration_T)+type Pc = (T.Note,T.Alteration) -pc_pp :: (T.Note_T, T.Alteration_T) -> [Char]+pc_pp :: Pc -> [Char] pc_pp (n,a) = T.note_pp n : T.alteration_iso a  -- | D = dominant, M = major@@ -62,25 +62,25 @@ chord_type_pcset = snd . chord_type_dat  -- (root,mode,extensions,bass)-data Chord = CH PC Chord_Type (Maybe Extension) (Maybe PC)+data Chord = Chord Pc Chord_Type (Maybe Extension) (Maybe Pc)              deriving (Show)  chord_pcset :: Chord -> (Maybe Int,[Int])-chord_pcset (CH pc ty ex bs) =+chord_pcset (Chord pc ty ex bs) =     let get = m_error "chord_pcset" . T.note_alteration_to_pc         pc' = get pc         ty' = chord_type_pcset ty         ex' = fmap extension_to_pc ex         bs' = fmap get bs         ch = map ((`mod` 12) . (+ pc')) (ty' ++ maybe [] return ex')-        ch' = maybe ch (flip delete ch) bs'+        ch' = maybe ch (`delete` ch) bs'     in (bs',ch') -bass_pp :: PC -> String+bass_pp :: Pc -> String bass_pp = ('/' :) . pc_pp  chord_pp :: Chord -> String-chord_pp (CH pc ty ex bs) =+chord_pp (Chord pc ty ex bs) =     let (pre_ty,post_ty) = if is_suspended ty                            then (Nothing,Just ty)                            else (Just ty,Nothing)@@ -90,21 +90,19 @@               ,maybe "" chord_type_pp post_ty               ,maybe "" bass_pp bs] -type P a = P.GenParser Char () a- m_error :: String -> Maybe a -> a m_error txt = fromMaybe (error txt) -p_pc :: P PC+p_pc :: T.P Pc p_pc = do   n <- T.p_note_t-  a <- P.optionMaybe T.p_alteration_t_iso+  a <- P.optionMaybe (T.p_alteration_t_iso True)   return (n,fromMaybe T.Natural a) -p_mode_m :: P T.Mode_T+p_mode_m :: T.P T.Mode p_mode_m = P.option T.Major_Mode (P.char 'm' >> return T.Minor_Mode) -p_chord_type :: P Chord_Type+p_chord_type :: T.P Chord_Type p_chord_type =     let m = P.char 'm' >> return Minor         au = P.char '+' >> return Augmented@@ -115,16 +113,16 @@         sus4 = P.try (P.string "sus4" >> return Suspended_4)     in P.option Major (P.choice [dm7,dm,hdm,au,sus2,sus4,m]) -p_extension :: P Extension+p_extension :: T.P Extension p_extension =     let d7 = P.char '7' >> return D7         m7 = P.try (P.string "M7" >> return M7)     in P.choice [d7,m7] -p_bass :: P (Maybe PC)+p_bass :: T.P (Maybe Pc) p_bass = P.optionMaybe (P.char '/' >> p_pc) -p_chord :: P Chord+p_chord :: T.P Chord p_chord = do   pc <- p_pc   ty <- p_chord_type@@ -136,7 +134,7 @@                (Major,Suspended_4) -> Suspended_4                (_,Major) -> ty -- ie. nothing                _ -> error ("trailing type not sus2 or sus4: " ++ show ty')-  return (CH pc ty'' ex b)+  return (Chord pc ty'' ex b)  -- | Parse chord. --
Music/Theory/Pitch/Note.hs view
@@ -5,68 +5,71 @@ 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 -}+import qualified Music.Theory.Parse as T {- hmt -} --- * Note_T+-- * Note  -- | Enumeration of common music notation note names (@C@ to @B@).-data Note_T = C | D | E | F | G | A | B+data Note = C | D | E | F | G | A | B               deriving (Eq,Enum,Bounded,Ord,Read,Show)  -- | Note sequence as usually understood, ie. 'C' - 'B'.-note_seq :: [Note_T]+note_seq :: [Note] note_seq = [C .. B]  -- | Char variant of 'show'.-note_pp :: Note_T -> Char+note_pp :: Note -> Char note_pp = head . show  -- | Note name in lilypond syntax (ie. lower case).-note_pp_ly :: Note_T -> String+note_pp_ly :: Note -> String note_pp_ly = map toLower . show --- | Table of 'Note_T' and corresponding pitch-classes.-note_pc_tbl :: Num i => [(Note_T,i)]+-- | Table of 'Note' and corresponding pitch-classes.+note_pc_tbl :: Num i => [(Note,i)] note_pc_tbl = zip [C .. B] [0,2,4,5,7,9,11] --- | Transform 'Note_T' to pitch-class number.+-- | Transform 'Note' to pitch-class number. -- -- > map note_to_pc [C,E,G] == [0,4,7]-note_to_pc :: Num i => Note_T -> i+note_to_pc :: Num i => Note -> i note_to_pc n = T.lookup_err_msg "note_to_pc" n note_pc_tbl  -- | Inverse of 'note_to_pc'. -- -- > mapMaybe pc_to_note [0,4,7] == [C,E,G]-pc_to_note :: (Eq i,Num i) => i -> Maybe Note_T+pc_to_note :: (Eq i,Num i) => i -> Maybe Note pc_to_note i = T.reverse_lookup i note_pc_tbl --- | Modal transposition of 'Note_T' value.+-- | Modal transposition of 'Note' value. -- -- > note_t_transpose C 2 == E-note_t_transpose :: Note_T -> Int -> Note_T+note_t_transpose :: Note -> Int -> Note note_t_transpose x n =     let x' = fromEnum x-        n' = fromEnum (maxBound::Note_T) + 1+        n' = fromEnum (maxBound::Note) + 1     in toEnum ((x' + n) `mod` n')  -- | Parser from 'Char', case insensitive flag. -- -- > mapMaybe (parse_note True) "CDEFGab" == [C,D,E,F,G,A,B]-parse_note_t :: Bool -> Char -> Maybe Note_T+parse_note_t :: Bool -> Char -> Maybe Note parse_note_t ci c =     let tbl = zip "CDEFGAB" [C,D,E,F,G,A,B]     in lookup (if ci then toUpper c else c) tbl --- | Inclusive set of 'Note_T' within indicated interval.  This is not+char_to_note_t :: Bool -> Char -> Note+char_to_note_t ci = fromMaybe (error "char_to_note_t") . parse_note_t ci++-- | Inclusive set of 'Note' within indicated interval.  This is not -- equal to 'enumFromTo' which is not circular. -- -- > note_span E B == [E,F,G,A,B] -- > note_span B D == [B,C,D] -- > enumFromTo B D == []-note_span :: Note_T -> Note_T -> [Note_T]+note_span :: Note -> Note -> [Note] note_span n1 n2 =     let fn x = toEnum (x `mod` 7)         n1' = fromEnum n1@@ -77,7 +80,7 @@ -- * Alteration  -- | Enumeration of common music notation note alterations.-data Alteration_T =+data Alteration =     DoubleFlat   | ThreeQuarterToneFlat | Flat | QuarterToneFlat   | Natural@@ -86,7 +89,7 @@     deriving (Eq,Enum,Bounded,Ord,Show)  -- | Generic form.-generic_alteration_to_diff :: Integral i => Alteration_T -> Maybe i+generic_alteration_to_diff :: Integral i => Alteration -> Maybe i generic_alteration_to_diff a =     case a of       DoubleFlat -> Just (-2)@@ -96,30 +99,30 @@       DoubleSharp -> Just 2       _ -> Nothing --- | Transform 'Alteration_T' to semitone alteration.  Returns+-- | Transform 'Alteration' to semitone alteration.  Returns -- 'Nothing' for non-semitone alterations. -- -- > map alteration_to_diff [Flat,QuarterToneSharp] == [Just (-1),Nothing]-alteration_to_diff :: Alteration_T -> Maybe Int+alteration_to_diff :: Alteration -> Maybe Int alteration_to_diff = generic_alteration_to_diff --- | Is 'Alteration_T' 12-ET.-alteration_is_12et :: Alteration_T -> Bool+-- | Is 'Alteration' 12-ET.+alteration_is_12et :: Alteration -> Bool alteration_is_12et = isJust . alteration_to_diff --- | Transform 'Alteration_T' to semitone alteration.+-- | Transform 'Alteration' to semitone alteration. -- -- > map alteration_to_diff_err [Flat,Sharp] == [-1,1]-alteration_to_diff_err :: Integral i => Alteration_T -> i+alteration_to_diff_err :: Integral i => Alteration -> i alteration_to_diff_err =     let err = error "alteration_to_diff: quarter tone"     in fromMaybe err . generic_alteration_to_diff --- | Transform 'Alteration_T' to fractional semitone alteration,+-- | Transform 'Alteration' to fractional semitone alteration, -- ie. allow quarter tones. -- -- > alteration_to_fdiff QuarterToneSharp == 0.5-alteration_to_fdiff :: Fractional n => Alteration_T -> n+alteration_to_fdiff :: Fractional n => Alteration -> n alteration_to_fdiff a =     case a of       ThreeQuarterToneFlat -> -1.5@@ -128,12 +131,12 @@       ThreeQuarterToneSharp -> 1.5       _ -> fromInteger (alteration_to_diff_err a) --- | Transform fractional semitone alteration to 'Alteration_T',+-- | Transform fractional semitone alteration to 'Alteration', -- ie. allow quarter tones. -- -- > map fdiff_to_alteration [-0.5,0.5] == [Just QuarterToneFlat -- >                                       ,Just QuarterToneSharp]-fdiff_to_alteration :: (Fractional n,Eq n) => n -> Maybe Alteration_T+fdiff_to_alteration :: (Fractional n,Eq n) => n -> Maybe Alteration fdiff_to_alteration d =     case d of       -2 -> Just DoubleFlat@@ -147,29 +150,29 @@       2 -> Just DoubleSharp       _ -> undefined --- | Raise 'Alteration_T' by a quarter tone where possible.+-- | Raise 'Alteration' by a quarter tone where possible. -- -- > alteration_raise_quarter_tone Flat == Just QuarterToneFlat -- > alteration_raise_quarter_tone DoubleSharp == Nothing-alteration_raise_quarter_tone :: Alteration_T -> Maybe Alteration_T+alteration_raise_quarter_tone :: Alteration -> Maybe Alteration alteration_raise_quarter_tone a =     if a == maxBound then Nothing else Just (toEnum (fromEnum a + 1)) --- | Lower 'Alteration_T' by a quarter tone where possible.+-- | Lower 'Alteration' by a quarter tone where possible. -- -- > alteration_lower_quarter_tone Sharp == Just QuarterToneSharp -- > alteration_lower_quarter_tone DoubleFlat == Nothing-alteration_lower_quarter_tone :: Alteration_T -> Maybe Alteration_T+alteration_lower_quarter_tone :: Alteration -> Maybe Alteration alteration_lower_quarter_tone a =     if a == minBound then Nothing else Just (toEnum (fromEnum a - 1)) --- | Edit 'Alteration_T' by a quarter tone where possible, @-0.5@+-- | Edit 'Alteration' by a quarter tone where possible, @-0.5@ -- lowers, @0@ retains, @0.5@ raises. -- -- > import Data.Ratio -- > alteration_edit_quarter_tone (-1 % 2) Flat == Just ThreeQuarterToneFlat alteration_edit_quarter_tone :: (Fractional n,Eq n) =>-                                n -> Alteration_T -> Maybe Alteration_T+                                n -> Alteration -> Maybe Alteration alteration_edit_quarter_tone n a =     case n of       -0.5 -> alteration_lower_quarter_tone a@@ -177,10 +180,10 @@       0.5 -> alteration_raise_quarter_tone a       _ -> Nothing --- | Simplify 'Alteration_T' to standard 12ET by deleting quarter tones.+-- | Simplify 'Alteration' to standard 12ET by deleting quarter tones. -- -- > Data.List.nub (map alteration_clear_quarter_tone [minBound..maxBound])-alteration_clear_quarter_tone :: Alteration_T -> Alteration_T+alteration_clear_quarter_tone :: Alteration -> Alteration alteration_clear_quarter_tone x =     case x of       ThreeQuarterToneFlat -> Flat@@ -190,7 +193,7 @@       _ -> x  -- | Table of Unicode characters for alterations.-alteration_symbol_tbl :: [(Alteration_T,Char)]+alteration_symbol_tbl :: [(Alteration,Char)] alteration_symbol_tbl =     [(DoubleFlat,'𝄫')     ,(ThreeQuarterToneFlat,'𝄭')@@ -208,19 +211,35 @@ -- UP@. -- -- > map alteration_symbol [minBound .. maxBound] == "𝄫𝄭♭𝄳♮𝄲♯𝄰𝄪"-alteration_symbol :: Alteration_T -> Char+alteration_symbol :: Alteration -> Char alteration_symbol a = fromMaybe (error "alteration_symbol") (lookup a alteration_symbol_tbl)  -- | Inverse of 'alteration_symbol'. -- -- > mapMaybe symbol_to_alteration "♭♮♯" == [Flat,Natural,Sharp]-symbol_to_alteration :: Char -> Maybe Alteration_T+symbol_to_alteration :: Char -> Maybe Alteration symbol_to_alteration c = T.reverse_lookup c alteration_symbol_tbl --- | Variant of 'symbol_to_alteration' that /also/ recognises @b@ for 'Flat'--- and @#@ for 'Sharp' and 'x' for double sharp.-symbol_to_alteration_iso :: Char -> Maybe Alteration_T-symbol_to_alteration_iso c =+-- | ISO alteration notation.  When not strict extended to allow ## for x.+symbol_to_alteration_iso :: Bool -> String -> Maybe Alteration+symbol_to_alteration_iso strict txt =+    case txt of+      "bb" -> Just DoubleFlat+      "b" -> Just Flat+      "#" -> Just Sharp+      "##" -> if strict then Nothing else Just DoubleSharp+      "x" -> Just DoubleSharp+      "" -> Just Natural+      _ -> Nothing++symbol_to_alteration_iso_err :: Bool -> String -> Alteration+symbol_to_alteration_iso_err strict =+  fromMaybe (error "symbol_to_alteration_iso") .+  symbol_to_alteration_iso strict++-- | 'symbol_to_alteration' extended to allow single character ISO notations.+symbol_to_alteration_unicode_plus_iso :: Char -> Maybe Alteration+symbol_to_alteration_unicode_plus_iso c =     case c of       'b' -> Just Flat       '#' -> Just Sharp@@ -228,7 +247,7 @@       _ -> symbol_to_alteration c  -- | ISO alteration table, strings not characters because of double flat.-alteration_iso_tbl :: [(Alteration_T,String)]+alteration_iso_tbl :: [(Alteration,String)] alteration_iso_tbl =     [(DoubleFlat,"bb")     ,(Flat,"b")@@ -241,17 +260,17 @@ -- -- > mapMaybe alteration_iso_m [Flat .. Sharp] == ["b","","#"] -- > mapMaybe alteration_iso_m [DoubleFlat,DoubleSharp] == ["bb","x"]-alteration_iso_m :: Alteration_T -> Maybe String+alteration_iso_m :: Alteration -> Maybe String alteration_iso_m a = lookup a alteration_iso_tbl  -- | The @ISO@ ASCII spellings for alterations.-alteration_iso :: Alteration_T -> String+alteration_iso :: Alteration -> String alteration_iso =     let qt = error "alteration_iso: quarter tone"     in fromMaybe qt . alteration_iso_m  -- | The /Tonhöhe/ ASCII spellings for alterations.-alteration_tonh_tbl :: [(Alteration_T, String)]+alteration_tonh_tbl :: [(Alteration, String)] alteration_tonh_tbl =   [(DoubleFlat,"eses")   ,(ThreeQuarterToneFlat,"eseh")@@ -269,19 +288,22 @@ -- <http://lilypond.org/doc/v2.16/Documentation/notation/writing-pitches> -- -- > map alteration_tonh [Flat .. Sharp] == ["es","eh","","ih","is"]-alteration_tonh :: Alteration_T -> String+alteration_tonh :: Alteration -> String 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 :: String -> Maybe Alteration tonh_to_alteration s = T.reverse_lookup s alteration_tonh_tbl +tonh_to_alteration_err :: String -> Alteration+tonh_to_alteration_err = fromMaybe (error "tonh_to_alteration") . tonh_to_alteration+ -- * 12-ET  -- | Note and alteration to pitch-class, or not.-note_alteration_to_pc :: (Note_T,Alteration_T) -> Maybe Int+note_alteration_to_pc :: (Note,Alteration) -> 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)@@ -289,21 +311,21 @@ -- | 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 :: (Note, Alteration) -> Int note_alteration_to_pc_err = fromMaybe (error "note_alteration_to_pc") . note_alteration_to_pc  -- | Note & alteration sequence in key-signature spelling.-note_alteration_ks :: [(Note_T, Alteration_T)]+note_alteration_ks :: [(Note, Alteration)] note_alteration_ks =     [(C,Natural),(C,Sharp),(D,Natural),(E,Flat),(E,Natural),(F,Natural)     ,(F,Sharp),(G,Natural),(A,Flat),(A,Natural),(B,Flat),(B,Natural)]  -- | Table connecting pitch class number with 'note_alteration_ks'.-pc_note_alteration_ks_tbl :: Integral i => [((Note_T,Alteration_T),i)]+pc_note_alteration_ks_tbl :: Integral i => [((Note,Alteration),i)] pc_note_alteration_ks_tbl = zip note_alteration_ks [0..11]  -- | 'T.reverse_lookup' of 'pc_note_alteration_ks_tbl'.-pc_to_note_alteration_ks :: Integral i => i -> Maybe (Note_T,Alteration_T)+pc_to_note_alteration_ks :: Integral i => i -> Maybe (Note,Alteration) pc_to_note_alteration_ks i = T.reverse_lookup i pc_note_alteration_ks_tbl  -- * Rational Alteration@@ -312,44 +334,41 @@ -- and a string representation of the alteration. type Alteration_R = (Rational,String) --- | Transform 'Alteration_T' to 'Alteration_R'.+-- | Transform 'Alteration' to 'Alteration_R'. -- -- > let r = [(-1,"♭"),(0,"♮"),(1,"♯")] -- > map alteration_r [Flat,Natural,Sharp] == r-alteration_r :: Alteration_T -> Alteration_R+alteration_r :: Alteration -> 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")+-- | Parser for ISO note name, upper case.+--+-- > map (T.run_parser_error p_note_t . return) "ABCDEFG"+p_note_t :: T.P Note+p_note_t = fmap (char_to_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")+-- | Note name in lower case (not ISO)+p_note_t_lc :: T.P Note+p_note_t_lc = fmap (char_to_note_t True) (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")+-- | Case-insensitive note name (not ISO).+p_note_t_ci :: T.P Note+p_note_t_ci = fmap (char_to_note_t True) (P.oneOf "abcdefgABCDEFG") --- > 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"))+-- | Parser for ISO alteration name.+--+-- > map (T.run_parser_error p_alteration_t_iso) (words "bb b # x ##")+p_alteration_t_iso :: Bool -> T.P Alteration+p_alteration_t_iso strict = fmap (symbol_to_alteration_iso_err strict) (P.many (P.oneOf "b#x")) --- > map (P.runP p_note_alteration_ly () "") ["c","ees","fis","aeses"]-p_note_alteration_ly :: P.GenParser Char () (Note_T,Maybe Alteration_T)+-- > map (T.run_parser_error p_alteration_t_tonh) ["eses","es","is","isis"]+p_alteration_t_tonh :: T.P Alteration+p_alteration_t_tonh = fmap tonh_to_alteration_err (P.many1 (P.oneOf "ehis"))++-- > map (T.run_parser_error p_note_alteration_ly) ["c","ees","fis","aeses"]+p_note_alteration_ly :: T.P (Note,Maybe Alteration) p_note_alteration_ly = do   n <- p_note_t_lc   a <- P.optionMaybe p_alteration_t_tonh
Music/Theory/Pitch/Note/Name.hs view
@@ -6,7 +6,7 @@  import Music.Theory.Pitch.Note -ceses,deses,eeses,feses,geses,aeses,beses :: (Note_T,Alteration_T)+ceses,deses,eeses,feses,geses,aeses,beses :: (Note,Alteration) ceses = (C,DoubleFlat) deses = (D,DoubleFlat) eeses = (E,DoubleFlat)@@ -15,7 +15,7 @@ aeses = (A,DoubleFlat) beses = (B,DoubleFlat) -ceseh,deseh,eeseh,feseh,geseh,aeseh,beseh :: (Note_T,Alteration_T)+ceseh,deseh,eeseh,feseh,geseh,aeseh,beseh :: (Note,Alteration) ceseh = (C,ThreeQuarterToneFlat) deseh = (D,ThreeQuarterToneFlat) eeseh = (E,ThreeQuarterToneFlat)@@ -24,7 +24,7 @@ aeseh = (A,ThreeQuarterToneFlat) beseh = (B,ThreeQuarterToneFlat) -ces,des,ees,fes,ges,aes,bes :: (Note_T,Alteration_T)+ces,des,ees,fes,ges,aes,bes :: (Note,Alteration) ces = (C,Flat) des = (D,Flat) ees = (E,Flat)@@ -33,7 +33,7 @@ aes = (A,Flat) bes = (B,Flat) -ceh,deh,eeh,feh,geh,aeh,beh :: (Note_T,Alteration_T)+ceh,deh,eeh,feh,geh,aeh,beh :: (Note,Alteration) ceh = (C,QuarterToneFlat) deh = (D,QuarterToneFlat) eeh = (E,QuarterToneFlat)@@ -42,7 +42,7 @@ aeh = (A,QuarterToneFlat) beh = (B,QuarterToneFlat) -c,d,e,f,g,a,b :: (Note_T,Alteration_T)+c,d,e,f,g,a,b :: (Note,Alteration) c = (C,Natural) d = (D,Natural) e = (E,Natural)@@ -51,7 +51,7 @@ a = (A,Natural) b = (B,Natural) -cih,dih,eih,fih,gih,aih,bih :: (Note_T,Alteration_T)+cih,dih,eih,fih,gih,aih,bih :: (Note,Alteration) cih = (C,QuarterToneSharp) dih = (D,QuarterToneSharp) eih = (E,QuarterToneSharp)@@ -60,7 +60,7 @@ aih = (A,QuarterToneSharp) bih = (B,QuarterToneSharp) -cis,dis,eis,fis,gis,ais,bis :: (Note_T,Alteration_T)+cis,dis,eis,fis,gis,ais,bis :: (Note,Alteration) cis = (C,Sharp) dis = (D,Sharp) eis = (E,Sharp)@@ -69,7 +69,7 @@ ais = (A,Sharp) bis = (B,Sharp) -cisih,disih,eisih,fisih,gisih,aisih,bisih :: (Note_T,Alteration_T)+cisih,disih,eisih,fisih,gisih,aisih,bisih :: (Note,Alteration) cisih = (C,ThreeQuarterToneSharp) disih = (D,ThreeQuarterToneSharp) eisih = (E,ThreeQuarterToneSharp)@@ -78,7 +78,7 @@ aisih = (A,ThreeQuarterToneSharp) bisih = (B,ThreeQuarterToneSharp) -cisis,disis,eisis,fisis,gisis,aisis,bisis :: (Note_T,Alteration_T)+cisis,disis,eisis,fisis,gisis,aisis,bisis :: (Note,Alteration) cisis = (C,DoubleSharp) disis = (D,DoubleSharp) eisis = (E,DoubleSharp)
Music/Theory/Pitch/Spelling.hs view
@@ -6,7 +6,7 @@ import qualified Music.Theory.Pitch.Spelling.Key as T {- hmt -} import qualified Music.Theory.Pitch.Spelling.Table as T {- hmt -} -spell_octpc_set :: [T.OctPC] -> [T.Pitch]+spell_octpc_set :: [T.OctPc] -> [T.Pitch] spell_octpc_set o =   case T.octpc_spell_implied_key o of     Just r -> r
Music/Theory/Pitch/Spelling/Cluster.hs view
@@ -14,12 +14,12 @@ cluster_normal_order :: [T.PitchClass] -> [T.PitchClass] cluster_normal_order =     let with_bounds x = ((last x - head x) `mod` 12,x)-    in snd . head . sort . map with_bounds . T.rotations+    in snd . minimum . map with_bounds . T.rotations  -- | Normal order starting in indicated octave. -- -- > cluster_normal_order_octpc 3 [0,1,11] == [(3,11),(4,0),(4,1)]-cluster_normal_order_octpc :: T.Octave -> [T.PitchClass] -> [T.OctPC]+cluster_normal_order_octpc :: T.Octave -> [T.PitchClass] -> [T.OctPc] cluster_normal_order_octpc o pc =     let pc_n = cluster_normal_order pc         pc_0 = head pc_n@@ -36,7 +36,7 @@ -- -- > let f (p,q) = (p == map T.note_alteration_to_pc_err q) -- > in all f spell_cluster_table-spell_cluster_table :: [([T.PitchClass],[(T.Note_T,T.Alteration_T)])]+spell_cluster_table :: [([T.PitchClass],[(T.Note,T.Alteration)])] spell_cluster_table =     [([0,1,2,3],[bis,cis,d,ees])     ,([0,1,2],[bis,cis,d])@@ -130,13 +130,13 @@     ,([9,10],[a,bes])     ,([9],[a])] -spell_cluster :: [T.PitchClass] -> Maybe [(T.Note_T,T.Alteration_T)]+spell_cluster :: [T.PitchClass] -> Maybe [(T.Note,T.Alteration)] spell_cluster = flip lookup spell_cluster_table --- | Spell an arbitrary sequence of 'T.OctPC' values.+-- | Spell an arbitrary sequence of 'T.OctPc' values. -- -- > fmap (map T.pitch_pp_iso) (spell_cluster_octpc [(3,11),(4,3),(4,11),(5,1)])-spell_cluster_octpc :: [T.OctPC] -> Maybe [T.Pitch]+spell_cluster_octpc :: [T.OctPc] -> Maybe [T.Pitch] spell_cluster_octpc o =     let p = cluster_normal_order (sort (nub (map snd o)))         na_f na =@@ -159,7 +159,7 @@         oct = map fst (cluster_normal_order_octpc o_0 p)     in case spell_cluster p of          Nothing -> Nothing-         Just na -> Just (map (\((n,alt),o) -> T.Pitch n alt o) (zip na oct))+         Just na -> Just (zipWith (\(n,alt) o -> T.Pitch n alt o) na oct)  -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave'.  An -- octave of @4@ is the identitiy, @3@ an octave below, @5@ an octave@@ -177,10 +177,10 @@ -- -- > import Data.Maybe ----- > let {f n = if n >= 11 then 3 else 4--- >     ;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+-- > let f n = if n >= 11 then 3 else 4+-- > let g = map T.pitch_pp .fromJust . spell_cluster_f f+-- > let r = [["B3","C4"],["B3"],["C4"],["A♯4","B4"]]+-- > 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]@@ -189,7 +189,7 @@                 [] -> []                 l:_ -> let (o,n) = T.pitch_to_octpc l                            oct_f = (+ (o_f n - o))-                       in (map (T.pitch_edit_octave oct_f) r)+                       in map (T.pitch_edit_octave oct_f) r     in fmap fn (spell_cluster_c4 p)  -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so
Music/Theory/Pitch/Spelling/Key.hs view
@@ -16,14 +16,14 @@                      else Just T.pc_spell_sharp  -- > map pcset_spell_implied_key [[0,1],[4,10],[3,9],[3,11]]-pcset_spell_implied_key :: Integral i => [i] -> Maybe [(T.Note_T, T.Alteration_T)]+pcset_spell_implied_key :: Integral i => [i] -> Maybe [(T.Note, T.Alteration)] pcset_spell_implied_key x =     case pcset_spell_implied_key_f x of       Just f -> Just (map f x)       Nothing -> Nothing  -- > map octpc_spell_implied_key [[(3,11),(4,1)],[(3,11),(4,10)]]-octpc_spell_implied_key :: [T.OctPC] -> Maybe [T.Pitch]+octpc_spell_implied_key :: [T.OctPc] -> Maybe [T.Pitch] octpc_spell_implied_key x =     let f o (n,a) = T.Pitch n a o     in fmap (zipWith f (map fst x)) (pcset_spell_implied_key (map snd x))
Music/Theory/Pitch/Spelling/Table.hs view
@@ -6,7 +6,7 @@ import qualified Music.Theory.Pitch as T {- hmt -} import Music.Theory.Pitch.Note {- hmt -} -type Spelling_Table i = [(i,(Note_T,Alteration_T))]+type Spelling_Table i = [(i,(Note,Alteration))]  -- | Spelling table for natural (♮) notes only. pc_spell_natural_tbl :: Integral i => Spelling_Table i@@ -90,7 +90,7 @@ 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'.+-- | 'T.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) @@ -99,3 +99,7 @@  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++-- | 'T.midi_to_pitch' 'pc_spell_sharp'+midi_to_pitch_sharp :: Integral i => i -> T.Pitch+midi_to_pitch_sharp = T.midi_to_pitch (pc_spell_sharp :: T.Spelling Int)
Music/Theory/Random/I_Ching.hs view
@@ -6,10 +6,10 @@ 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 -}+import qualified Music.Theory.Bits as T {- hmt-base -}+import qualified Music.Theory.Read as T {- hmt-base -}+import qualified Music.Theory.Tuple as T {- hmt-base -}+import qualified Music.Theory.Unicode as T {- hmt-base -}  -- * LINE @@ -41,7 +41,7 @@  -- | Seven character ASCII string for line. line_ascii_pp :: Line -> String-line_ascii_pp n = fromMaybe (error "line_ascii_pp") (fmap T.p5_fifth (lookup n i_ching_chart))+line_ascii_pp n = maybe (error "line_ascii_pp") T.p5_fifth (lookup n i_ching_chart)  -- | Is line (ie. sum) moving (ie. 6 or 9). line_is_moving :: Line -> Bool
− Music/Theory/Read.hs 
@@ -1,194 +0,0 @@--- | Read functions.-module Music.Theory.Read where--import Data.Char {- base -}-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.--- Requires using all the input to produce a single token.  The only--- exception is a singular trailing white space character.-reads_to_read_precise :: ReadS t -> (String -> Maybe t)-reads_to_read_precise f s =-    case f s of-      [(r,[])] -> Just r-      [(r,[c])] -> if isSpace c then Just r else Nothing-      _ -> Nothing---- | Error variant of 'reads_to_read_precise'.-reads_to_read_precise_err :: String -> ReadS t -> String -> t-reads_to_read_precise_err err f =-    fromMaybe (error ("reads_to_read_precise_err:" ++ err)) .-    reads_to_read_precise f---- | 'reads_to_read_precise' of 'reads'.------ > read_maybe "1.0" :: Maybe Int-read_maybe :: Read a => String -> Maybe a-read_maybe = reads_to_read_precise reads---- | Variant of 'read_maybe' with default value.------ > map (read_def 0) ["2","2:","2\n"] == [2,0,2]-read_def :: Read a => a -> String -> a-read_def x s = maybe x id (read_maybe s)---- | Variant of 'read_maybe' that errors on 'Nothing', 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 = read_err_msg "read_maybe failed"---- | Variant of 'reads' requiring exact match, no trailing white space.------ > map reads_exact ["1.5","2,5"] == [Just 1.5,Nothing]-reads_exact :: Read a => String -> Maybe a-reads_exact s =-    case reads s of-      [(r,"")] -> Just r-      _ -> Nothing---- | Variant of 'reads_exact' that errors on failure.-reads_exact_err :: Read a => String -> String -> a-reads_exact_err err_txt str =-    let err = error ("reads: " ++ err_txt ++ ": " ++ str)-    in fromMaybe err (reads_exact str)---- * Type specific variants---- | Allow commas as thousand separators.------ > let r = [Just 123456,Just 123456,Nothing,Just 123456789]--- > in map read_integral_allow_commas_maybe ["123456","123,456","1234,56","123,456,789"]-read_integral_allow_commas_maybe :: Read i => String -> Maybe i-read_integral_allow_commas_maybe s =-    let c = filter ((== ',') . fst) (zip (reverse s) [0..])-    in if null c-       then read_maybe s-       else if map snd c `isPrefixOf` [3::Int,7..]-            then read_maybe (filter (not . (== ',')) s)-            else Nothing--read_integral_allow_commas_err :: (Integral i,Read i) => String -> i-read_integral_allow_commas_err s =-    let err = error ("read_integral_allow_commas: misplaced commas: " ++ s)-    in fromMaybe err (read_integral_allow_commas_maybe s)--read_int_allow_commas :: String -> Int-read_int_allow_commas = read_integral_allow_commas_err---- | Read a ratio where the division is given by @/@ instead of @%@--- and the integers allow commas.------ > map read_ratio_with_div_err ["123,456/7","123,456,789"] == [123456/7,123456789]-read_ratio_with_div_err :: (Integral i, Read i) => String -> Ratio i-read_ratio_with_div_err s =-    let f = read_integral_allow_commas_err-    in case break (== '/') s of-         (n,'/':d) -> f n % f d-         _ -> read_integral_allow_commas_err s % 1---- | Read 'Ratio', allow commas for thousand separators.------ > read_ratio_allow_commas_err "327,680" "177,147" == 327680 / 177147-read_ratio_allow_commas_err :: (Integral i,Read i) => String -> String -> Ratio i-read_ratio_allow_commas_err n d = let f = read_integral_allow_commas_err in f n % f d---- | Delete trailing @.@, 'read' fails for @700.@.-delete_trailing_point :: String -> String-delete_trailing_point s =-    case reverse s of-      '.':s' -> reverse s'-      _ -> s---- | 'read_err' disallows trailing decimal points.------ > map read_fractional_allow_trailing_point_err ["123.","123.4"] == [123.0,123.4]-read_fractional_allow_trailing_point_err :: Read n => String -> n-read_fractional_allow_trailing_point_err = read_err . delete_trailing_point---- * Plain type specialisations---- | Type specialised 'read_maybe'.------ > map read_maybe_int ["2","2:","2\n","x"] == [Just 2,Nothing,Just 2,Nothing]-read_maybe_int :: String -> Maybe Int-read_maybe_int = read_maybe---- | Type specialised 'read_err'.-read_int :: String -> Int-read_int = read_err---- | Type specialised 'read_maybe'.-read_maybe_double :: String -> Maybe Double-read_maybe_double = read_maybe---- | Type specialised 'read_err'.-read_double :: String -> Double-read_double = read_err---- | Type specialised 'read_maybe'.------ > map read_maybe_rational ["1","1%2","1/2"] == [Nothing,Just (1/2),Nothing]-read_maybe_rational :: String -> Maybe Rational-read_maybe_rational = read_maybe---- | Type specialised 'read_err'.------ > read_rational "1%4"-read_rational :: String -> Rational-read_rational = read_err---- * Numeric variants---- | Read binary integer.------ > mapMaybe read_bin (words "000 001 010 011 100 101 110 111") == [0 .. 7]-read_bin :: Integral a => String -> Maybe a-read_bin = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt---- | Erroring variant.-read_bin_err :: Integral a => String -> a-read_bin_err = fromMaybe (error "read_bin") . read_bin---- * HEX---- | Error variant of 'readHex'.------ > read_hex_err "F0B0" == 61616-read_hex_err :: (Eq n,Num n) => String -> n-read_hex_err = reads_to_read_precise_err "readHex" readHex---- | Read hex value from string of at most /k/ places.-read_hex_sz :: (Eq n, Num n) => Int -> String -> n-read_hex_sz k str =-  if length str > k-  then error "read_hex_sz? = > K"-  else case readHex str of-         [(r,[])] -> r-         _ -> error "read_hex_sz? = PARSE"---- | Read hexadecimal representation of 32-bit unsigned word.------ > map read_hex_word32 ["00000000","12345678","FFFFFFFF"] == [minBound,305419896,maxBound]-read_hex_word32 :: String -> Word32-read_hex_word32 = read_hex_sz 8---- * RATIONAL---- | Parser for 'rational_pp'.------ > map rational_parse ["1","3/2","5/4","2"] == [1,3/2,5/4,2]--- > rational_parse "" == undefined-rational_parse :: (Read t,Integral t) => String -> Ratio t-rational_parse s =-  case break (== '/') s of-    ([],_) -> error "rational_parse"-    (n,[]) -> read n % 1-    (n,_:d) -> read n % read d-
Music/Theory/Set/List.hs view
@@ -3,9 +3,10 @@  import Control.Monad {- base -} import Data.List {- base -}+ import qualified Math.Combinatorics.Multiset as M {- multiset-comb -} -import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.List as T {- hmt-base -}  -- | 'sort' then 'nub'. --@@ -28,9 +29,9 @@  -- | Variant where result is sorted and the empty set is not given. ----- > powerset' [1,2,3] == [[1],[2],[3],[1,2],[1,3],[2,3],[1,2,3]]-powerset' :: Ord a => [a] -> [[a]]-powerset' = tail . T.sort_by_two_stage_on length id . powerset+-- > powerset_sorted [1,2,3] == [[1],[2],[3],[1,2],[1,3],[2,3],[1,2,3]]+powerset_sorted :: Ord a => [a] -> [[a]]+powerset_sorted = tail . T.sort_by_two_stage_on length id . powerset  -- | Two element subsets. --@@ -41,12 +42,14 @@       [] -> []       x:s' -> [(x,y) | y <- s'] ++ pairs s' --- | Three element subsets.------ > triples [1..4] == [(1,2,3),(1,2,4),(1,3,4),(2,3,4)]------ > let f n = genericLength (triples [1..n]) == nk_combinations n 3--- > in all f [1..15]+{- | Three element subsets.++> triples [1..4] == [(1,2,3),(1,2,4),(1,3,4),(2,3,4)]++> import Music.Theory.Combinations+> let f n = genericLength (triples [1..n]) == nk_combinations n 3+> all f [1..15]+-} triples :: [a] -> [(a,a,a)] triples s =     case s of@@ -62,23 +65,18 @@     then [xs]     else nub (concatMap (expand_set n) [sort (y : xs) | y <- xs]) --- | All distinct multiset partitions, see 'M.partitions'.------ > partitions "aab" == [["aab"],["a","ab"],["b","aa"],["b","a","a"]]------ > partitions "abc" == [["abc"]--- >                     ,["bc","a"],["b","ac"],["c","ab"]--- >                     ,["c","b","a"]]+{- | All distinct multiset partitions, see 'M.partitions'.++> partitions "aab" == [["aab"],["a","ab"],["b","aa"],["b","a","a"]]+> partitions "abc" == [["abc"],["bc","a"],["b","ac"],["c","ab"],["c","b","a"]]+-} partitions :: Eq a => [a] -> [[[a]]] partitions = map (map M.toList . M.toList) . M.partitions . M.fromListEq  {- | Cartesian product of two sets. -> let r = [('a',1),('a',2),('b',1),('b',2),('c',1),('c',2)]-> in cartesian_product "abc" [1,2] == r-+> cartesian_product "abc" [1,2] == [('a',1),('a',2),('b',1),('b',2),('c',1),('c',2)] > cartesian_product "abc" "" == []- -} cartesian_product :: [a] -> [b] -> [(a,b)] cartesian_product p q = [(i,j) | i <- p, j <- q]@@ -94,3 +92,10 @@       [_] -> []       [x,y] -> [[i,j] | i <- x, j <- y]       x:l' -> concatMap (\e -> map (e :) (nfold_cartesian_product l')) x++{- | Generate all distinct cycles, aka necklaces, with elements taken from a multiset.++> concatMap multiset_cycles [replicate i 0 ++ replicate (6 - i) 1 | i <- [0 .. 6]]+-}+multiset_cycles :: Ord t => [t] -> [[t]]+multiset_cycles = M.cycles . M.fromList
Music/Theory/Set/Set.hs view
@@ -2,7 +2,8 @@ module Music.Theory.Set.Set where  import qualified Data.Set as S {- containers -}-import qualified Music.Theory.Set.List as L++import qualified Music.Theory.Set.List as L {- hmt -}  set :: (Ord a) => [a] -> S.Set a set = S.fromList
− Music/Theory/Show.hs 
@@ -1,130 +0,0 @@--- | Show functions.-module Music.Theory.Show where--import Data.Char {- base -}-import Data.List {- base -}-import Data.Ratio {- base -}-import Numeric {- base -}--import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Math as T {- hmt -}-import qualified Music.Theory.Math.Convert as T {- hmt -}---- * DIFF---- | Show positive and negative values always with sign, maybe show zero, maybe right justify.------ > map (num_diff_str_opt (True,2)) [-2,-1,0,1,2] == ["-2","-1"," 0","+1","+2"]-num_diff_str_opt :: (Ord a, Num a, Show a) => (Bool,Int) -> a -> String-num_diff_str_opt (wr_0,k) n =-  let r = case compare n 0 of-            LT -> '-' : show (abs n)-            EQ -> if wr_0 then "0" else ""-            GT -> '+' : show n-  in if k > 0 then T.pad_left ' ' k r else r---- | Show /only/ positive and negative values, always with sign.------ > map num_diff_str [-2,-1,0,1,2] == ["-2","-1","","+1","+2"]--- > map show [-2,-1,0,1,2] == ["-2","-1","0","1","2"]-num_diff_str :: (Num a, Ord a, Show a) => a -> String-num_diff_str = num_diff_str_opt (False,0)---- * RATIONAL---- | Pretty printer for 'Rational' using @/@ and eliding denominators of @1@.------ > map rational_pp [1,3/2,5/4,2] == ["1","3/2","5/4","2"]-rational_pp :: (Show a,Integral a) => Ratio a -> String-rational_pp r =-    let n = numerator r-        d = denominator r-    in if d == 1-       then show n-       else concat [show n,"/",show d]---- | Pretty print ratio as @:@ separated integers, if /nil/ is True elide unit denominator.------ > map (ratio_pp_opt True) [1,3/2,2] == ["1","3:2","2"]-ratio_pp_opt :: Bool -> Rational -> String-ratio_pp_opt nil r =-  let f :: (Integer,Integer) -> String-      f (n,d) = concat [show n,":",show d]-  in case T.rational_nd r of-       (n,1) -> if nil then show n else f (n,1)-       x -> f x---- | Pretty print ratio as @:@ separated integers.------ > map ratio_pp [1,3/2,2] == ["1:1","3:2","2:1"]-ratio_pp :: Rational -> String-ratio_pp = ratio_pp_opt False---- | Show rational to /n/ decimal places.------ > let r = approxRational pi 1e-100--- > r == 884279719003555 / 281474976710656--- > show_rational_decimal 12 r == "3.141592653590"--- > show_rational_decimal 3 (-100) == "-100.000"-show_rational_decimal :: Int -> Rational -> String-show_rational_decimal n = double_pp n . fromRational---- * REAL---- | Show /r/ as float to /k/ places.------ > real_pp 4 (1/3 :: Rational) == "0.3333"--- > map (real_pp 4) [1,1.1,1.12,1.123,1.1234,1/0,sqrt (-1)]-real_pp :: Real t => Int -> t -> String-real_pp k = realfloat_pp k . T.real_to_double---- | Variant that writes `∞` for Infinity.------ > putStrLn $ unwords $ map (real_pp_unicode 4) [1/0,-1/0]-real_pp_unicode :: Real t => Int -> t -> [Char]-real_pp_unicode k r =-  case real_pp k r of-    "Infinity" -> "∞"-    "-Infinity" -> "-∞"-    s -> s---- | Prints /n/ as integral or to at most /k/ decimal places. Does not print -0.------ > real_pp_trunc 4 (1/3 :: Rational) == "0.3333"--- > map (real_pp_trunc 4) [1,1.1,1.12,1.123,1.1234] == ["1","1.1","1.12","1.123","1.1234"]--- > map (real_pp_trunc 4) [1.00009,1.00001] == ["1.0001","1"]--- > map (real_pp_trunc 2) [59.999,60.001,-0.00,-0.001]-real_pp_trunc :: Real t => Int -> t -> String-real_pp_trunc k n =-  case break (== '.') (real_pp k n) of-    (i,[]) -> i-    (i,j) -> case dropWhileEnd (== '0') j of-               "." -> if i == "-0" then "0" else i-               z -> i ++ z---- | Variant of 'showFFloat'.  The 'Show' instance for floats resorts--- to exponential notation very readily.------ > [show 0.01,realfloat_pp 2 0.01] == ["1.0e-2","0.01"]--- > map (realfloat_pp 4) [1,1.1,1.12,1.123,1.1234,1/0,sqrt (-1)]-realfloat_pp :: RealFloat a => Int -> a -> String-realfloat_pp k n = showFFloat (Just k) n ""---- | Type specialised 'realfloat_pp'.-float_pp :: Int -> Float -> String-float_pp = realfloat_pp---- | Type specialised 'realfloat_pp'.------ > double_pp 4 0-double_pp :: Int -> Double -> String-double_pp = realfloat_pp---- * BIN---- | Read binary integer.------ > unwords (map (show_bin Nothing) [0 .. 7]) == "0 1 10 11 100 101 110 111"--- > unwords (map (show_bin (Just 3)) [0 .. 7]) == "000 001 010 011 100 101 110 111"-show_bin :: (Integral i,Show i) => Maybe Int -> i -> String-show_bin k n = (maybe id (\x -> T.pad_left '0' x) k) (showIntAtBase 2 intToDigit n "")
− Music/Theory/String.hs 
@@ -1,40 +0,0 @@--- | String functions.-module Music.Theory.String where--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')---- | Delete trailing 'Char' where 'isSpace' holds.------ > delete_trailing_whitespace "   str   " == "   str"-delete_trailing_whitespace :: String -> String-delete_trailing_whitespace = reverse . dropWhile isSpace . reverse--{- | Variant of 'unwords' that does not write spaces for NIL elements.--> unwords_nil [] == ""-> unwords_nil ["a"] == "a"-> unwords_nil ["a",""] == "a"-> unwords_nil ["a","b"] == "a b"-> unwords_nil ["a","","b"] == "a b"-> unwords_nil ["a","","","b"] == "a b"-> unwords_nil ["a","b",""] == "a b"-> unwords_nil ["a","b","",""] == "a b"-> unwords_nil ["","a","b"] == "a b"-> unwords_nil ["","","a","b"] == "a b"--}-unwords_nil :: [String] -> String-unwords_nil = unwords . filter (not . null)---- | Variant of 'unlines' that does not write empty lines for NIL elements.-unlines_nil :: [String] -> String-unlines_nil = unlines . filter (not . null)
Music/Theory/Tempo_Marking.hs view
@@ -4,16 +4,16 @@ import Data.List {- base -}  import Music.Theory.Duration-import Music.Theory.Duration.RQ+import Music.Theory.Duration.Rq import Music.Theory.Time_Signature  -- | A tempo marking is in terms of a common music notation 'Duration'. type Tempo_Marking = (Duration,Rational) --- | Duration of a RQ value, in seconds, given indicated tempo.+-- | Duration of a Rq value, in seconds, given indicated tempo. -- -- > rq_to_seconds (quarter_note,90) 1 == 60/90-rq_to_seconds :: Tempo_Marking -> RQ -> Rational+rq_to_seconds :: Tempo_Marking -> Rq -> Rational rq_to_seconds (d,n) x =     let d' = duration_to_rq d         s = 60 / n
Music/Theory/Tiling/Canon.hs view
@@ -1,5 +1,6 @@ module Music.Theory.Tiling.Canon where +import Control.Monad {- base -} import Data.List {- base -} import Data.List.Split {- split -} import Text.Printf {- base -}@@ -37,16 +38,17 @@ e_to_seq :: E -> [Int] e_to_seq (s,m,o) = map ((+ o) . (* m)) s --- | Infer 'E' from sequence.------ > e_from_seq [1,5,11] == ([0,2,5],2,1)--- > e_from_seq [4,7] == ([0,1],3,4)--- > e_from_seq [2] == ([0],1,2)+{- | Infer 'E' from sequence.++> e_from_seq [1,5,11] == ([0,2,5],2,1)+> e_from_seq [4,7] == ([0,1],3,4)+> e_from_seq [2] == ([0],1,2)+-} e_from_seq :: [Int] -> E e_from_seq p =-    let i:_ = p+    let i = head p         q = map (+ negate i) p-        _:r = q+        r = tail q         n = if null r then 1 else foldl1 gcd r     in (map (`div` n) q,n,i) @@ -63,7 +65,7 @@ -- | Retrograde of 'T', the result 'T' is sorted. -- -- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]--- > in t_retrograde [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r+-- > t_retrograde [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r t_retrograde :: T -> T t_retrograde t =     let n = maximum (concat t)@@ -72,46 +74,47 @@ -- | The normal form of 'T' is the 'min' of /t/ and it's 't_retrograde'. -- -- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]--- > in t_normal [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r+-- > t_normal [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r t_normal :: T -> T t_normal t = min t (t_retrograde t) --- | Derive set of 'R' from 'T'.------ > let {r = [(21,[0,1,2],[10,8,2,4,7,5,1],[0,1,2,3,5,8,14])]--- >     ;t = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]}--- > in r_from_t t == r+{- | Derive set of 'R' from 'T'.++> let r = [(21,[0,1,2],[10,8,2,4,7,5,1],[0,1,2,3,5,8,14])]+> let t = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]+> r_from_t t == r+-} r_from_t :: T -> [R] r_from_t t =     let e = map e_from_seq t         n = maximum (concat t) + 1         t3_1 (i,_,_) = i-        f z = let (s:_,m,o) = unzip3 z in (n,s,m,o)+        f z = let (s,m,o) = unzip3 z in (n,head s,m,o)     in map f (T.group_on t3_1 e)  -- * Construction  -- | 'msum' '.' 'map' 'return'. ----- > observeAll (fromList [1..7]) == [1..7]-fromList :: L.MonadPlus m => [a] -> m a-fromList = L.msum . map return+-- > L.observeAll (fromList [1..7]) == [1..7]+fromList :: MonadPlus m => [a] -> m a+fromList = msum . map return  -- | Search for /perfect/ tilings of the sequence 'S' using -- multipliers from /m/ to degree /n/ with /k/ parts.-perfect_tilings_m :: L.MonadPlus m => [S] -> [Int] -> Int -> Int -> m T+perfect_tilings_m :: MonadPlus m => [S] -> [Int] -> Int -> Int -> m T perfect_tilings_m s m n k =     let rec p q =             if length q == k             then return (sort q)             else do m' <- fromList m-                    L.guard (m' `notElem` p)+                    guard (m' `notElem` p)                     s' <- fromList s                     let i = n - (maximum s' * m') - 1                     o <- fromList [0..i]                     let s'' = e_to_seq (s',m',o)                         q' = concat q-                    L.guard (all (`notElem` q') s'')+                    guard (all (`notElem` q') s'')                     rec (m':p) (s'':q)     in rec [] [] @@ -120,14 +123,12 @@ > perfect_tilings [[0,1]] [1..3] 6 3 == []  > let r = [[[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]]-> in perfect_tilings [[0,1,2]] [1,2,4,5,7] 15 5 == r+> perfect_tilings [[0,1,2]] [1,2,4,5,7] 15 5 == r  > length (perfect_tilings [[0,1,2]] [1..12] 15 5) == 1 -> let r = [[[0,1],[2,5],[3,7],[4,6]]->         ,[[0,1],[2,6],[3,5],[4,7]]->         ,[[0,2],[1,4],[3,7],[5,6]]]-> in perfect_tilings [[0,1]] [1..4] 8 4 == r+> let r = [[[0,1],[2,5],[3,7],[4,6]], [[0,1],[2,6],[3,5],[4,7]] ,[[0,2],[1,4],[3,7],[5,6]]]+> perfect_tilings [[0,1]] [1..4] 8 4 == r  > let r = [[[0,1],[2,5],[3,7],[4,9],[6,8]] >         ,[[0,1],[2,7],[3,5],[4,8],[6,9]]@@ -139,10 +140,10 @@ Johnson 2004, p.2  > let r = [[0,6,12],[1,8,15],[2,11,20],[3,5,7],[4,9,14],[10,13,16],[17,18,19]]-> in perfect_tilings [[0,1,2]] [1,2,3,5,6,7,9] 21 7 == [r]+> perfect_tilings [[0,1,2]] [1,2,3,5,6,7,9] 21 7 == [r]  > let r = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]-> in perfect_tilings [[0,1,2]] [1,2,4,5,7,8,10] 21 7 == [t_retrograde r]+> perfect_tilings [[0,1,2]] [1,2,4,5,7,8,10] 21 7 == [t_retrograde r]  -} perfect_tilings :: [S] -> [Int] -> Int -> Int -> [T]
Music/Theory/Time/Bel1990/R.hs view
@@ -11,7 +11,7 @@   Centre National de la Recherche Scientifique, 1992. /GRTC 458/   (<http://www.lpl.univ-aix.fr/~belbernard/music/2algorithms.pdf>) -For details see <http://rd.slavepianos.org/t/hmt-texts>.+For details see <http://rohandrape.net/?t=hmt-texts>. -}  module Music.Theory.Time.Bel1990.R where@@ -22,18 +22,16 @@ import Data.Ratio {- base -}  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.Parse as T import qualified Music.Theory.Show as T  -- * Bel  -- | Types of 'Par' nodes.-data Par_Mode = Par_Left | Par_Right-              | Par_Min | Par_Max-              | Par_None-              deriving (Eq,Show)+data Par_Mode = Par_Left | Par_Right | Par_Min | Par_Max | Par_None+  deriving (Eq, Show)  -- | The different 'Par' modes are indicated by bracket types. par_mode_brackets :: Par_Mode -> (String,String)@@ -45,6 +43,17 @@       Par_Max -> ("{","}")       Par_None -> ("[","]") +-- | Inverse of par_mode_brackets+par_mode_kind :: (String, String) -> Par_Mode+par_mode_kind brk =+  case brk of+    ("{","}") -> Par_Max+    ("~{","}") -> Par_Min+    ("(",")") -> Par_Left+    ("~(",")") -> Par_Right+    ("[","]") -> Par_None+    _ -> error "par_mode_kind: incoherent par"+ bel_brackets_match :: (Char,Char) -> Bool bel_brackets_match (open,close) =     case (open,close) of@@ -53,25 +62,43 @@       ('[',']') -> True       _ -> False --- | Tempo is rational.  The duration of a 'Term' is the reciprocal of--- the 'Tempo' that is in place at the 'Term'.+{- | Tempo is rational.+The duration of a 'Term' is the reciprocal of the 'Tempo' that is in place at the 'Term'.+-} type Tempo = Rational  -- | Terms are the leaf nodes of the temporal structure.-data Term a = Value a-            | Rest-            | Continue-           deriving (Eq,Show)+data Term a = Value a | Rest | Continue+  deriving (Eq,Show) +-- | Value of Term, else Nothing+term_value :: Term t -> Maybe t+term_value t =+  case t of+    Value x -> Just x+    _ -> Nothing+ -- | Recursive temporal structure.-data Bel a = Node (Term a) -- ^ Leaf node-           | Iso (Bel a) -- ^ Isolate-           | Seq (Bel a) (Bel a) -- ^ Sequence-           | Par Par_Mode (Bel a) (Bel a) -- ^ Parallel-           | Mul Tempo -- ^ Tempo multiplier-           deriving (Eq,Show)+data Bel a =+  Node (Term a) -- ^ Leaf node+  | Iso (Bel a) -- ^ Isolate+  | Seq (Bel a) (Bel a) -- ^ Sequence+  | Par Par_Mode (Bel a) (Bel a) -- ^ Parallel+  | Mul Tempo -- ^ Tempo multiplier+  deriving (Eq,Show) --- | Pretty printer for 'Bel', given pretty printer for the term type.+-- | Given a Par mode, generate either: 1. an Iso, 2. a Par, 3. a series of nested Par.+par_of :: Par_Mode -> [Bel a] -> Bel a+par_of m l =+  case l of+    [] -> error "par_of: null"+    [e] -> Iso e+    lhs : rhs : [] -> Par m lhs rhs+    e : l' -> Par m e (par_of m l')++{- | Pretty printer for 'Bel', given pretty printer for the term type.+Note this does not write nested Par nodes in their simplified form.+-} bel_pp :: (a -> String) -> Bel a -> String bel_pp f b =     case b of@@ -89,13 +116,14 @@ bel_char_pp :: Bel Char -> String bel_char_pp = bel_pp return --- | Analyse a Par node giving (duration,LHS-tempo-*,RHS-tempo-*).------ > par_analyse 1 Par_Left (nseq "cd") (nseq "efg") == (2,1,3/2)--- > par_analyse 1 Par_Right (nseq "cd") (nseq "efg") == (3,2/3,1)--- > par_analyse 1 Par_Min (nseq "cd") (nseq "efg") == (2,1,3/2)--- > par_analyse 1 Par_Max (nseq "cd") (nseq "efg") == (3,2/3,1)--- > par_analyse 1 Par_None (nseq "cd") (nseq "efg") == (3,1,1)+{- | Analyse a Par node giving (duration,LHS-tempo-*,RHS-tempo-*).++> par_analyse 1 Par_Left (nseq "cd") (nseq "efg") == (2,1,3/2)+> par_analyse 1 Par_Right (nseq "cd") (nseq "efg") == (3,2/3,1)+> par_analyse 1 Par_Min (nseq "cd") (nseq "efg") == (2,1,3/2)+> par_analyse 1 Par_Max (nseq "cd") (nseq "efg") == (3,2/3,1)+> par_analyse 1 Par_None (nseq "cd") (nseq "efg") == (3,1,1)+-} par_analyse :: Tempo -> Par_Mode -> Bel a -> Bel a -> (Rational,Rational,Rational) par_analyse t m p q =     let (_,d_p) = bel_tdur t p@@ -135,14 +163,17 @@ -- | Time point. type Time = Rational --- | Voices are named as a sequence of left and right directions--- within nested 'Par' structures.+{- | Voices are named as a sequence of left and right directions within nested 'Par' structures.+l is left and r is right.+-} type Voice = [Char] --- | Linear state.  'Time' is the start time of the term, 'Tempo' is--- the active tempo & therefore the reciprocal of the duration,--- 'Voice' is the part label.-type L_St = (Time,Tempo,Voice)+{- | Linear state.+'Time' is the start time of the term.+'Tempo' is the active tempo & therefore the reciprocal of the duration.+'Voice' is the part label.+-}+type L_St = (Time, Tempo, Voice)  -- | Linear term. type L_Term a = (L_St,Term a)@@ -159,6 +190,18 @@ lterm_end_time :: L_Term a -> Time lterm_end_time e = lterm_time e + lterm_duration e +-- | Voice of 'L_Term'.+lterm_voice :: L_Term t -> Voice+lterm_voice ((_,_,vc),_) = vc++-- | Term of L_Term+lterm_term :: L_Term t -> Term t+lterm_term (_,t) = t++-- | Value of Term of L_Term+lterm_value :: L_Term t -> Maybe t+lterm_value = term_value . lterm_term+ -- | Linear form of 'Bel', an ascending sequence of 'L_Term'. type L_Bel a = [L_Term a] @@ -194,18 +237,25 @@ lbel_tempo_mul :: Rational -> L_Bel a -> L_Bel a lbel_tempo_mul n = map (\((st,tm,vc),e) -> ((st / n,tm * n,vc),e)) --- | After normalisation all start times and durations are integral.+{- | The multiplier that will normalise an L_Bel value.+     After normalisation all start times and durations are integral.+-}+lbel_normalise_multiplier :: L_Bel t -> Rational+lbel_normalise_multiplier b =+  let t = lbel_tempi b+      n = foldl1 lcm (map denominator t) % 1+      m = foldl1 lcm (map (numerator . (* n)) t) % 1+  in n / m++-- | Calculate and apply L_Bel normalisation multiplier. lbel_normalise :: L_Bel a -> L_Bel a-lbel_normalise b =-    let t = lbel_tempi b-        n = foldl1 lcm (map denominator t) % 1-        m = foldl1 lcm (map numerator (map (* n) t)) % 1-    in lbel_tempo_mul (n / m) b+lbel_normalise b = lbel_tempo_mul (lbel_normalise_multiplier b) b --- | All leftmost voices are re-written to the last non-left turning point.------ > map voice_normalise ["","l","ll","lll"] == replicate 4 ""--- > voice_normalise "lllrlrl" == "rlrl"+{- | All leftmost voices are re-written to the last non-left turning point.++> map voice_normalise ["","l","ll","lll"] == replicate 4 ""+> voice_normalise "lllrlrl" == "rlrl"+-} voice_normalise :: Voice -> Voice voice_normalise = dropWhile (== 'l') @@ -273,10 +323,11 @@ (~>) :: Bel a -> Bel a -> Bel a p ~> q = Seq p q --- | 'foldl1' of 'Seq'.------ > lseq [Node Rest] == Node Rest--- > lseq [Node Rest,Node Continue] == Seq (Node Rest) (Node Continue)+{- | 'foldl1' of 'Seq'.++> lseq [Node Rest] == Node Rest+> lseq [Node Rest,Node Continue] == Seq (Node Rest) (Node Continue)+-} lseq :: [Bel a] -> Bel a lseq = foldl1 Seq @@ -313,9 +364,10 @@ bel_parse_pp_ident :: String -> Bool bel_parse_pp_ident s = bel_char_pp (bel_char_parse s) == s --- | Run 'bel_char_parse', and print both 'bel_char_pp' and 'bel_ascii'.------ > bel_ascii_pp "{i{ab,{c[d,oh]e,sr{p,qr}}},{jk,ghjkj}}"+{- | Run 'bel_char_parse', and print both 'bel_char_pp' and 'bel_ascii'.++> bel_ascii_pp "{i{ab,c[d,oh]e,sr{p,qr}},{jk,ghjkj}}"+-} bel_ascii_pp :: String -> IO () bel_ascii_pp s = do   let p = bel_char_parse s@@ -324,55 +376,52 @@  -- * Parsing --- | A 'Char' parser.-type P a = P.GenParser Char () a- -- | Parse 'Rest' 'Term'. -- -- > P.parse p_rest "" "-"-p_rest :: P (Term a)-p_rest = liftM (const Rest) (P.char '-')+p_rest :: T.P (Term a)+p_rest = fmap (const Rest) (P.char '-')  -- | Parse 'Rest' 'Term'. -- -- > P.parse p_nrests "" "3"-p_nrests :: P (Bel a)-p_nrests = liftM nrests p_non_negative_integer+p_nrests :: T.P (Bel a)+p_nrests = fmap nrests p_non_negative_integer  -- | Parse 'Continue' 'Term'. -- -- > P.parse p_continue "" "_"-p_continue :: P (Term a)-p_continue = liftM (const Continue) (P.char '_')+p_continue :: T.P (Term a)+p_continue = fmap (const Continue) (P.char '_')  -- | Parse 'Char' 'Value' 'Term'. -- -- > P.parse p_char_value "" "a"-p_char_value :: P (Term Char)-p_char_value = liftM Value P.lower+p_char_value :: T.P (Term Char)+p_char_value = fmap Value P.lower  -- | Parse 'Char' 'Term'. -- -- > P.parse (P.many1 p_char_term) "" "-_a"-p_char_term :: P (Term Char)+p_char_term :: T.P (Term Char) p_char_term = P.choice [p_rest,p_continue,p_char_value]  -- | Parse 'Char' 'Node'. -- -- > P.parse (P.many1 p_char_node) "" "-_a"-p_char_node :: P (Bel Char)-p_char_node = liftM Node p_char_term+p_char_node :: T.P (Bel Char)+p_char_node = fmap Node p_char_term  -- | Parse non-negative 'Integer'. -- -- > P.parse p_non_negative_integer "" "3"-p_non_negative_integer :: P Integer-p_non_negative_integer = liftM read (P.many1 P.digit)+p_non_negative_integer :: T.P Integer+p_non_negative_integer = fmap read (P.many1 P.digit)  -- | Parse non-negative 'Rational'. -- -- > P.parse (p_non_negative_rational `P.sepBy` (P.char ',')) "" "3%5,2/3"-p_non_negative_rational :: P Rational+p_non_negative_rational :: T.P Rational p_non_negative_rational = do   n <- p_non_negative_integer   _ <- P.oneOf "%/"@@ -383,7 +432,7 @@ -- -- > P.parse p_non_negative_double "" "3.5" -- > P.parse (p_non_negative_double `P.sepBy` (P.char ',')) "" "3.5,7.2,1.0"-p_non_negative_double :: P Double+p_non_negative_double :: T.P Double p_non_negative_double = do   a <- P.many1 P.digit   _ <- P.char '.'@@ -393,16 +442,16 @@ -- | Parse non-negative number as 'Rational'. -- -- > P.parse (p_non_negative_number `P.sepBy` (P.char ',')) "" "7%2,3.5,3"-p_non_negative_number :: P Rational+p_non_negative_number :: T.P Rational p_non_negative_number =     P.choice [P.try p_non_negative_rational-             ,P.try (liftM toRational p_non_negative_double)-             ,P.try (liftM toRational p_non_negative_integer)]+             ,P.try (fmap toRational p_non_negative_double)+             ,P.try (fmap toRational p_non_negative_integer)]  -- | Parse 'Mul'. -- -- > P.parse (P.many1 p_mul) "" "/3*3/2"-p_mul :: P (Bel a)+p_mul :: T.P (Bel a) p_mul = do   op <- P.oneOf "*/"   n <- p_non_negative_number@@ -413,50 +462,43 @@   return (Mul n')  -- | Given parser for 'Bel' /a/, generate 'Iso' parser.-p_iso :: P (Bel a) -> P (Bel a)+p_iso :: T.P (Bel a) -> T.P (Bel a) p_iso f = do   open <- P.oneOf "{(["   iso <- P.many1 f   close <- P.oneOf "})]"-  if bel_brackets_match (open,close)-    then return (Iso (lseq iso))-    else error "p_iso: open/close mismatch"+  when (not (bel_brackets_match (open,close))) (error "p_iso: open/close mismatch")+  return (Iso (lseq iso))  -- | 'p_iso' of 'p_char_bel'. -- -- > P.parse p_char_iso "" "{abcde}"-p_char_iso :: P (Bel Char)+p_char_iso :: T.P (Bel Char) p_char_iso = p_iso p_char_bel  -- | Given parser for 'Bel' /a/, generate 'Par' parser.-p_par :: P (Bel a) -> P (Bel a)+p_par :: T.P (Bel a) -> T.P (Bel a) p_par f = do   tilde <- P.optionMaybe (P.char '~')   open <- P.oneOf "{(["-  lhs <- P.many1 f-  _ <- P.char ','-  rhs <- P.many1 f+  items <- P.sepBy (P.many1 f) (P.char ',')   close <- P.oneOf "})]"-  let m = case (tilde,open,close) of-            (Nothing,'{','}') -> Par_Max-            (Just '~','{','}') -> Par_Min-            (Nothing,'(',')') -> Par_Left-            (Just '~','(',')') -> Par_Right-            (Nothing,'[',']') -> Par_None-            _ -> error "p_par: incoherent par"-  return (Par m (lseq lhs) (lseq rhs))+  let m = par_mode_kind (T.mcons tilde [open], [close])+  return (par_of m (map lseq items)) --- | 'p_par' of 'p_char_bel'.------ > P.parse p_char_par "" "{ab,{c,de}}"--- > P.parse p_char_par "" "{ab,~(c,de)}"-p_char_par :: P (Bel Char)+{- | 'p_par' of 'p_char_bel'.++> p = P.parse p_char_par ""+> p "{ab,{c,de}}" == p "{ab,c,de}"+> p "{ab,~(c,de)}"+-}+p_char_par :: T.P (Bel Char) p_char_par = p_par p_char_bel  -- | Parse 'Bel' 'Char'. -- -- > P.parse (P.many1 p_char_bel) "" "-_a*3"-p_char_bel :: P (Bel Char)+p_char_bel :: T.P (Bel Char) p_char_bel = P.choice [P.try p_char_par,p_char_iso,p_mul,p_nrests,p_char_node]  -- | Run parser for 'Bel' of 'Char'.
− Music/Theory/Time/Duration.hs 
@@ -1,148 +0,0 @@-module Music.Theory.Time.Duration where--import qualified Data.List.Split as S {- split -}-import Text.Printf {- base -}---- | Duration stored as /hours/, /minutes/, /seconds/ and /milliseconds/.-data Duration = Duration {hours :: Int-                         ,minutes :: Int-                         ,seconds :: Int-                         ,milliseconds :: Int}-                deriving (Eq)---- | Convert fractional /seconds/ to integral /(seconds,milliseconds)/.------ > s_sms 1.75 == (1,750)-s_sms :: (RealFrac n,Integral i) => n -> (i,i)-s_sms s =-    let s' = floor s-        ms = round ((s - fromIntegral s') * 1000)-    in (s',ms)---- | Inverse of 's_sms'.------ > sms_s (1,750) == 1.75-sms_s :: (Integral i) => (i,i) -> Double-sms_s (s,ms) = fromIntegral s + fromIntegral ms / 1000---- | 'Read' function for 'Duration' tuple.-read_duration_tuple :: String -> (Int,Int,Int,Int)-read_duration_tuple x =-    let f :: (Int,Int,Double) -> (Int,Int,Int,Int)-        f (h,m,s) = let (s',ms) = s_sms s in (h,m,s',ms)-    in case S.splitOneOf ":" x of-        [h,m,s] -> f (read h,read m,read s)-        [m,s] -> f (0,read m,read s)-        [s] -> f (0,0,read s)-        _ -> error "read_duration_tuple"---- | 'Read' function for 'Duration'.  Allows either @H:M:S.MS@ or--- @M:S.MS@ or @S.MS@.------ > read_duration "01:35:05.250" == Duration 1 35 5 250--- > read_duration    "35:05.250" == Duration 0 35 5 250--- > read_duration       "05.250" == Duration 0 0 5 250-read_duration :: String -> Duration-read_duration = tuple_to_duration id . read_duration_tuple--instance Read Duration where-    readsPrec _ x = [(read_duration x,"")]---- | 'Show' function for 'Duration'.------ > show_duration (Duration 1 35 5 250) == "01:35:05.250"--- > show (Duration 1 15 0 000) == "01:15:00.000"-show_duration :: Duration -> String-show_duration (Duration h m s ms) =-    let f :: Int -> String-        f = printf "%02d"-        g = f . fromIntegral-        s' = sms_s (s,ms)-    in concat [g h,":",g m,":",printf "%06.3f" s']--instance Show Duration where-    show = show_duration--normalise_minutes :: Duration -> Duration-normalise_minutes (Duration h m s ms) =-    let (h',m') = m `divMod` 60-    in Duration (h + h') m' s ms--normalise_seconds :: Duration -> Duration-normalise_seconds (Duration h m s ms) =-    let (m',s') = s `divMod` 60-    in Duration h (m + m') s' ms--normalise_milliseconds :: Duration -> Duration-normalise_milliseconds (Duration h m s ms) =-    let (s',ms') = ms `divMod` 1000-    in Duration h m (s + s') ms'--normalise_duration :: Duration -> Duration-normalise_duration =-    normalise_minutes .-    normalise_seconds .-    normalise_milliseconds---- | Extract 'Duration' tuple applying filter function at each element------ > duration_tuple id (Duration 1 35 5 250) == (1,35,5,250)-duration_to_tuple :: (Int -> a) -> Duration -> (a,a,a,a)-duration_to_tuple f (Duration h m s ms) = (f h,f m,f s,f ms)---- | Inverse of 'duration_to_tuple'.-tuple_to_duration :: (a -> Int) -> (a,a,a,a) -> Duration-tuple_to_duration f (h,m,s,ms) = Duration (f h) (f m) (f s) (f ms)---- > duration_to_hours (read "01:35:05.250") == 1.5847916666666668-duration_to_hours :: Fractional n => Duration -> n-duration_to_hours d =-    let (h,m,s,ms) = duration_to_tuple fromIntegral d-    in h + (m / 60) + (s / (60 * 60)) + (ms / (60 * 60 * 1000))---- > duration_to_minutes (read "01:35:05.250") == 95.0875-duration_to_minutes :: Fractional n => Duration -> n-duration_to_minutes = (* 60) . duration_to_hours---- > duration_to_seconds (read "01:35:05.250") == 5705.25-duration_to_seconds :: Fractional n => Duration -> n-duration_to_seconds = (* 60) . duration_to_minutes---- > hours_to_duration 1.5847916 == Duration 1 35 5 250-hours_to_duration :: RealFrac a => a -> Duration-hours_to_duration n =-    let r = fromIntegral :: RealFrac a => Int -> a-        h = (r . floor) n-        m = (n - h) * 60-        (s,ms) = s_sms ((m - (r . floor) m) * 60)-    in Duration (floor h) (floor m) s ms--minutes_to_duration :: RealFrac a => a -> Duration-minutes_to_duration n = hours_to_duration (n / 60)--seconds_to_duration :: RealFrac a => a -> Duration-seconds_to_duration n = minutes_to_duration (n / 60)--nil_duration :: Duration-nil_duration = Duration 0 0 0 0--negate_duration :: Duration -> Duration-negate_duration (Duration h m s ms) =-    let h' = if h > 0 then -h else h-        m' = if h == 0 && m > 0 then -m else m-        s' = if h == 0 && m == 0 && s > 0 then -s else s-        ms' = if h == 0 && m == 0 && s == 0 then -ms else ms-    in Duration h' m' s' ms'---- > duration_diff (Duration 1 35 5 250) (Duration 0 25 1 125) == Duration 1 10 4 125--- > duration_diff (Duration 0 25 1 125) (Duration 1 35 5 250) == Duration (-1) 10 4 125--- > duration_diff (Duration 0 25 1 125) (Duration 0 25 1 250) == Duration 0 0 0 (-125)-duration_diff :: Duration -> Duration -> Duration-duration_diff p q =-    let f = duration_to_hours :: Duration -> Double-        (p',q') = (f p,f q)-        g = normalise_duration . hours_to_duration-    in case compare p' q' of-         LT -> negate_duration (g (q' - p'))-         EQ -> nil_duration-         GT -> g (p' - q')
+ Music/Theory/Time/KeyKit.hs view
@@ -0,0 +1,236 @@+{- | A sequence structure, courtesy <https://github.com/nosuchtim/keykit>.++A /note/ has a time, a duration and a value.+A /phrase/ is a time-ascending sequence of notes and a /length/.+The length of a phrase is independent of the contents.+The sequence operator, /phrase_append/, sums phrase lengths.+The parallel operator, /phrase_merge/, selects the longer length.++Operations are ordinarily on phrases, notes are operated on indirectly.+The phrase indexing operation, /phrase_at/ returns a phrase of degree one.+-}+module Music.Theory.Time.KeyKit where++import Data.List {- base -}++import qualified Data.List.Ordered as O {- data-ordlist -}++import qualified Music.Theory.Time.Seq as Seq {- hmt -}++-- * Time++type Time = Rational+type Duration = Time+type Length = Time++-- * Note++data Note t =+  Note { note_start_time :: Time, note_duration :: Duration, note_value :: t }+  deriving (Eq, Ord, Show)++note_end_time :: Note t -> Time+note_end_time n = note_start_time n + note_duration n++note_region :: Note t -> (Time, Time)+note_region n = (note_start_time n, note_end_time n)++note_shift_time :: Time -> Note t -> Note t+note_shift_time k (Note t d e) = Note (t + k) d e++note_scale_duration :: Time -> Note t -> Note t+note_scale_duration m (Note t d e) = Note t (d * m) e++note_scale_duration_and_time :: Time -> Note t -> Note t+note_scale_duration_and_time m (Note t d e) = Note (t * m) (d * m) e++note_is_start_in_region :: (Time, Time) -> Note t -> Bool+note_is_start_in_region (t1, t2) (Note t _ _) = t >= t1 && t < t2++note_is_entirely_in_region :: (Time, Time) -> Note t -> Bool+note_is_entirely_in_region (t1, t2) (Note t d _) = t >= t1 && (t + d) < t2++-- * Phrase++-- | It is an un-checked invariant that the note list is in ascending order.+data Phrase t =+  Phrase { phrase_notes :: [Note t], phrase_length :: Length }+  deriving (Eq, Ord, Show)++phrase_values :: Phrase t -> [t]+phrase_values = map note_value . phrase_notes++phrase_set_length :: Phrase t -> Length -> Phrase t+phrase_set_length (Phrase n _) l = Phrase n l++phrase_degree :: Phrase t -> Int+phrase_degree (Phrase n _) = length n++phrase_start_time :: Phrase t -> Time+phrase_start_time (Phrase n _) =+  case n of+    [] -> 0+    n1 : _ -> note_start_time n1++phrase_end_time :: Phrase t -> Time+phrase_end_time (Phrase n _) =+  case n of+    [] -> 0+    _ -> note_start_time (last n)++phrase_duration :: Phrase t -> Duration+phrase_duration p = phrase_end_time p - phrase_start_time p++phrase_maximum :: Ord t => Phrase t -> Note t+phrase_maximum (Phrase n _) = maximum n++phrase_minimum :: Ord t => Phrase t -> Note t+phrase_minimum (Phrase n _) = minimum n++-- | Keykit sets the length to the duration, i.e. ('c,e,g'%2).length is 192.+phrase_at :: Phrase t -> Int -> Phrase t+phrase_at (Phrase n _) k =+  let nt = n !! (k - 1)+  in Phrase [nt] (note_start_time nt + note_duration nt)++phrase_time_at :: Phrase t -> Int -> Time+phrase_time_at (Phrase n _) k = note_start_time (n !! (k - 1))++phrase_clear_at :: Phrase t -> Int -> Phrase t+phrase_clear_at (Phrase n l) k =+  let remove_ix ix list = let (p,q) = splitAt ix list in p ++ tail q+  in Phrase (remove_ix (k - 1) n) l++phrase_at_put :: Ord t => Phrase t -> Int -> Phrase t -> Phrase t+phrase_at_put (Phrase n1 l1) k (Phrase n2 _) =+  let nt = n1 !! (k - 1)+      remove_ix ix list = let (p,q) = splitAt ix list in p ++ tail q+  in Phrase (O.merge (remove_ix (k - 1) n1) (map (note_shift_time (note_start_time nt)) n2)) l1++phrase_is_empty :: Phrase t -> Bool+phrase_is_empty (Phrase n _) = null n++-- | KeyKits p+q+phrase_append :: Ord t => Phrase t -> Phrase t -> Phrase t+phrase_append (Phrase n1 l1) (Phrase n2 l2) = Phrase (O.merge n1 (map (note_shift_time l1) n2)) (l1 + l2)++phrase_append_list :: Ord t => [Phrase t] -> Phrase t+phrase_append_list = foldl1' phrase_append++-- | KeyKits p|q+phrase_merge :: Ord t => Phrase t -> Phrase t -> Phrase t+phrase_merge (Phrase n1 l1) (Phrase n2 l2) = Phrase (O.merge n1 n2) (max l1 l2)++phrase_merge_list :: Ord t => [Phrase t] -> Phrase t+phrase_merge_list p =+  let l = maximum (map phrase_length p)+      n = sort (concatMap phrase_notes p)+  in Phrase n l++phrase_select :: Phrase t -> (Note t -> Bool) -> Phrase t+phrase_select (Phrase n l) f = Phrase (filter f n) l++phrase_partition :: Phrase t -> (Note t -> Bool) -> (Phrase t, Phrase t)+phrase_partition (Phrase n l) f =+  let (n1, n2) = partition f n+  in (Phrase n1 l, Phrase n2 l)++phrase_select_region :: Phrase t -> (Time, Time) -> Phrase t+phrase_select_region p r = phrase_select p (note_is_start_in_region r)++phrase_clear_region :: Phrase t -> (Time, Time) -> Phrase t+phrase_clear_region p r = phrase_select p (not . note_is_start_in_region r)++phrase_select_indices :: Phrase t -> (Int, Int) -> Phrase t+phrase_select_indices (Phrase n l) (i, j) = Phrase (take (j - i + 1) (drop (i - 1) n)) l++phrase_clear_indices :: Phrase t -> (Int, Int) -> Phrase t+phrase_clear_indices (Phrase n l) (i, j) = Phrase (take (i - 1) n ++ drop j n) l++phrase_extract_region :: Phrase t -> (Time, Time) -> Phrase t+phrase_extract_region p (t1, t2) =+  let p' = phrase_select_region p (t1, t2)+  in phrase_set_length (phrase_shift p' (0 - t1)) (t2 - t1)++phrase_delete_region :: Ord t => Phrase t -> (Time, Time) -> Phrase t+phrase_delete_region p (t1, t2) =+  phrase_append+  (phrase_extract_region p (0, t1))+  (phrase_extract_region p (t2, phrase_length p))++phrase_separate :: Phrase t -> Time -> (Phrase t, Phrase t)+phrase_separate p t =+  let (p1, p2) = phrase_partition p (note_is_start_in_region (0, t))+      p1' = phrase_set_length p1 t+      p2' = phrase_set_length (phrase_shift p2 (0 - t)) (phrase_length p - t)+  in (p1', p2')++phrase_reverse :: Phrase t -> Phrase t+phrase_reverse (Phrase n l) =+  let f (Note t d e) = Note (l - t - d) d e+  in Phrase (reverse (map f n)) l++phrase_reorder :: Phrase t -> [Int] -> Phrase t+phrase_reorder (Phrase n l) p =+  let f (Note t d _) i = Note t d (note_value (n !! (i - 1)))+  in Phrase (zipWith f n p) l++phrase_truncate :: Phrase t -> Phrase t+phrase_truncate p = phrase_set_length p (phrase_end_time p)++phrase_trim :: Phrase t -> Phrase t+phrase_trim p =+  let t = phrase_start_time p+  in phrase_truncate (phrase_shift p (0 - t))++-- * Functor++note_map :: (t -> u) -> Note t -> Note u+note_map f (Note t d e) = Note t d (f e)++phrase_value_map :: (t -> u) -> Phrase t -> Phrase u+phrase_value_map f (Phrase n l) = Phrase (map (note_map f) n) l++phrase_note_map :: (Note t -> Note u) -> Phrase t -> Phrase u+phrase_note_map f (Phrase n l) = Phrase (map f n) l++phrase_phrase_map :: Ord u => (Phrase t -> Phrase u) -> Phrase t -> Phrase u+phrase_phrase_map f (Phrase n l) =+  let g (Note t d e) = f (Phrase [Note t d e] (t + d))+  in Phrase (sort (concatMap phrase_notes (map g n))) l++phrase_map :: Ord u => (Note t -> Phrase u) -> Phrase t -> Phrase u+phrase_map f (Phrase n l) = Phrase (sort (concatMap phrase_notes (map f n))) l++phrase_shift :: Phrase t -> Time -> Phrase t+phrase_shift p t = phrase_note_map (note_shift_time t) p++phrase_scale_duration :: Phrase t -> Time -> Phrase t+phrase_scale_duration p m = phrase_note_map (note_scale_duration m) p++phrase_scale_duration_and_time :: Phrase t -> Time -> Phrase t+phrase_scale_duration_and_time p m = phrase_note_map (note_scale_duration_and_time m) p++phrase_scale_to_duration :: Phrase t -> Duration -> Phrase t+phrase_scale_to_duration p d = phrase_scale_duration_and_time p (d / phrase_length p)++phrase_scale_to_region :: Phrase t -> (Time, Duration) -> Phrase t+phrase_scale_to_region p (t1, t2) = phrase_shift (phrase_scale_to_duration p (t2 - t1)) t1++-- * Seq++phrase_to_wseq :: Phrase t -> Seq.Wseq Time t+phrase_to_wseq (Phrase n _) =+  let f (Note tm dur e) = ((tm, dur), e)+  in map f n++useq_to_phrase :: Seq.Useq Time t -> Phrase t+useq_to_phrase = dseq_to_phrase . Seq.useq_to_dseq++dseq_to_phrase :: Seq.Dseq Time t -> Phrase t+dseq_to_phrase = wseq_to_phrase . Seq.dseq_to_wseq 0++wseq_to_phrase :: Seq.Wseq Time t -> Phrase t+wseq_to_phrase sq =+  let f ((t, d), e) = Note t d e+  in Phrase (map f sq) (Seq.wseq_dur sq)
+ Music/Theory/Time/KeyKit/Basic.hs view
@@ -0,0 +1,52 @@+-- | Translations of some functions from <https://github.com/nosuchtim/keykit/blob/master/lib/basic1.k>+module Music.Theory.Time.KeyKit.Basic where++import Data.List {- base -}++import qualified Music.Theory.List as List {- hmt-base -}++import Music.Theory.Time.KeyKit {- hmt -}++{- | Returns an arpeggiated version of the phrase.+One way of describing desc it is that all the notes have been separated and then put back together, back-to-back.++> phrase_arpeggio (wseq_to_phrase (zip (repeat (0,1)) [60, 64, 67]))+-}+phrase_arpeggio :: Phrase t -> Phrase t+phrase_arpeggio (Phrase n l) =+  case n of+    [] -> Phrase n l+    n1 : _ ->+      let t_seq = scanl (+) (note_start_time n1) (map note_duration n)+          n' = zipWith (\t (Note _ d e) -> Note t d e) t_seq n+          l' = note_end_time (last n)+      in Phrase n' l'++-- | Return phrase ph echoed num times, with rtime delay between each echo.+phrase_echo :: Ord t => Phrase t -> Int -> Time -> Phrase t+phrase_echo p n t = phrase_merge_list (map (\i -> phrase_shift p (fromIntegral i * t)) [0 .. n - 1])++{- | Convert a phrase to be in step time, ie. all notes with the same spacing and duration.+Overlapped notes (no matter how small the overlap) are played at the same time.++> phrase_step (wseq_to_phrase [((0, 1), 60), ((5, 2), 64), ((23, 3), 67)]) 1+-}+phrase_step :: Phrase t -> Duration -> Phrase t+phrase_step (Phrase n _) d =+  let g = groupBy (\i j -> note_start_time i == note_start_time j) n+      f l t = map (\(Note _ _ e) -> Note t d e) l+      n' = concat (zipWith f g [0, d ..])+  in Phrase n' (note_end_time (last n'))++{- | This function takes a phrase, splits in in 2 halves (along time) and shuffles the result+(ie. first a note from the first half, then a note from the second half, etc.).+The timing of the original phrase is applied to the result.++> phrase_to_wseq (phrase_shuffle (useq_to_phrase (1,[1..9])))+-}+phrase_shuffle :: Phrase t -> Phrase t+phrase_shuffle (Phrase n l) =+  let (lhs, rhs) = List.split_into_halves (map note_value n)+      f (Note t d _) e = Note t d e+      n' = zipWith f n (concat (transpose [lhs, rhs]))+  in Phrase n' l
+ Music/Theory/Time/KeyKit/Parser.hs view
@@ -0,0 +1,249 @@+-- | KeyKit phrase literal (constant) parser and printer.+module Music.Theory.Time.KeyKit.Parser where++import Data.Maybe {- base -}+import Text.Printf {- base -}++import qualified Text.Parsec as P {- parsec -}+import qualified Text.Parsec.String as String {- parsec -}++-- * Parser setup++-- | A 'Char' parser with no user state.+type P a = String.GenParser Char () a++-- | Run parser and return either an error string or an answer.+kk_parse_either :: P t -> String -> Either String t+kk_parse_either p = either (\m -> Left ("kk_parse: " ++ show m)) Right . P.parse p ""++-- | Run parser and report any error.  Does not delete leading spaces.+kk_parse :: P t -> String -> t+kk_parse p = either (\e -> error e) id . kk_parse_either p++-- | Run p then q, returning result of p.+(>>~) :: Monad m => m t -> m u -> m t+p >>~ q = p >>= \x -> q >> return x++kk_lexeme :: P t -> P t+kk_lexeme p = p >>~ P.many P.space++kk_uint :: P Int+kk_uint = do+  digits <- P.many1 P.digit+  return (read digits)++kk_int :: P Int+kk_int = do+  sign <- P.optionMaybe (P.char '-')+  unsigned <- kk_uint+  return (maybe unsigned (const (negate unsigned)) sign)++-- * Note elements parsers++kk_note_name_p :: P Char+kk_note_name_p = P.oneOf "abcdefg"++kk_midi_note_p :: P Int+kk_midi_note_p = P.char 'p' >> kk_uint++kk_rest_p :: P Char+kk_rest_p = P.char 'r'++kk_accidental_p :: P Char+kk_accidental_p = P.oneOf "+-"++kk_char_to_note_number :: Char -> Int+kk_char_to_note_number c = fromMaybe (error "kk_char_to_note_number?") (lookup c (zip "cdefgab" [0, 2, 4, 5, 7, 9, 11]))++kk_char_to_alteration :: Char -> Int+kk_char_to_alteration c = fromMaybe (error "kk_char_to_alteration?") (lookup c (zip "+-" [1, -1]))++-- > map kk_note_number_to_name [0 .. 11]+kk_note_number_to_name :: Int -> String+kk_note_number_to_name k = fromMaybe (error "kk_note_number_to_name?") (lookup k (zip [0..] (words "c c+ d e- e f f+ g a- a b- b")))++kk_named_note_number_p :: P Int+kk_named_note_number_p = do+  nm <- kk_note_name_p+  ac <- P.optionMaybe kk_accidental_p+  return (kk_char_to_note_number nm + maybe 0 kk_char_to_alteration ac)++kk_note_number_p :: P Int+kk_note_number_p = kk_named_note_number_p P.<|> kk_midi_note_p++-- | The octave key can be elided, ordinarily directly after the note name, ie. c2.+kk_modifier_p :: P (Char, Int)+kk_modifier_p = do+  c <- P.optionMaybe (P.oneOf "ovdct")+  n <- kk_int+  return (fromMaybe 'o' c, n)++kk_modifiers_p :: P [(Char, Int)]+kk_modifiers_p = P.many kk_modifier_p++-- * Contextual note++{- | A note where all fields are optional.+If the note number is absent it indicates a rest.+All other fields infer values from the phrase context.+-}+data Kk_Contextual_Note =+  Kk_Contextual_Note+  {kk_contextual_note_number :: Maybe Int+  ,kk_contextual_note_octave :: Maybe Int+  ,kk_contextual_note_volume :: Maybe Int+  ,kk_contextual_note_duration :: Maybe Int+  ,kk_contextual_note_channel :: Maybe Int+  ,kk_contextual_note_time :: Maybe Int}+  deriving (Eq, Ord, Show)++kk_empty_contextual_note :: Kk_Contextual_Note+kk_empty_contextual_note = Kk_Contextual_Note Nothing Nothing Nothing Nothing Nothing Nothing++kk_empty_contextual_rest :: Int -> Kk_Contextual_Note+kk_empty_contextual_rest n = kk_empty_contextual_note {kk_contextual_note_duration = Just n}++{- | If t is set and is at the end time of the previous note print a preceding comma, else print t annotation.++> c = kk_empty_contextual_note {kk_contextual_note_number = Just 0, kk_contextual_time = Just 96}+> map (\t -> kk_contextual_note_pp (t, c)) [0, 96] == ["ct96",", c"]+-}+kk_contextual_note_pp :: (Int, Kk_Contextual_Note) -> String+kk_contextual_note_pp (t', Kk_Contextual_Note n o v d c t) =+  let f i j = maybe "" ((if i == 'o' then id else (i :)) . show) j+      (pre, t'') = if t == Just t' then (", ","") else ("", f 't' t)+  in case n of+          Nothing -> concat [pre, "r", f 'd' d, t'']+          Just k -> concat [pre, kk_note_number_to_name k, f 'o' o, f 'v' v, f 'd' d, f 'c' c, t'']++{- | If the note number is given as p60, then derive octave of and set it, ignoring any modifier.+Note that in KeyKit c3 is p60 or middle c.+-}+kk_contextual_note_p :: P Kk_Contextual_Note+kk_contextual_note_p = do+  n <- fmap Just kk_note_number_p P.<|> (kk_rest_p >> return Nothing)+  m <- kk_modifiers_p+  _ <- P.many P.space+  let get c = lookup c m+      (n', o) =+        case n of+          Just n'' ->+            if n'' > 11+            then+              let (o', n''') = n'' `divMod` 12+              in (Just n''', Just (o' - 2))+            else (n, get 'o')+          Nothing -> (Nothing, Nothing)+  return (Kk_Contextual_Note n' o (get 'v') (get 'd') (get 'c') (get 't'))++kk_contextual_note_is_rest :: Kk_Contextual_Note -> Bool+kk_contextual_note_is_rest = isNothing . kk_contextual_note_number++kk_comma_p :: P Char+kk_comma_p = kk_lexeme (P.char ',')++-- | A contextual note and an is_parallel? indicator.+kk_contextual_phrase_element_p :: P (Kk_Contextual_Note, Bool)+kk_contextual_phrase_element_p = do+  n <- kk_contextual_note_p+  c <- P.optionMaybe kk_comma_p+  return (n, isNothing c)++kk_contextual_phrase_p :: P [(Kk_Contextual_Note, Bool)]+kk_contextual_phrase_p = P.many kk_contextual_phrase_element_p++-- * Note++-- | A note with all fields required.+data Kk_Note =+  Kk_Note+  {kk_note_number :: Int+  ,kk_note_octave :: Int+  ,kk_note_volume :: Int+  ,kk_note_duration :: Int+  ,kk_note_channel :: Int+  ,kk_note_time :: Int}+  deriving (Eq, Ord, Show)++kk_default_note :: Kk_Note+kk_default_note = Kk_Note 60 3 63 96 1 0++kk_note_to_initial_contextual_note :: Kk_Note -> Kk_Contextual_Note+kk_note_to_initial_contextual_note (Kk_Note n o v d c t) =+  let f i j = if i == j then Nothing else Just i+  in Kk_Contextual_Note (Just n) (f o 3) (f v 63) (f d 96) (f c 1) (f t 0)++kk_note_to_contextual_note :: Kk_Note -> Kk_Note -> (Int, Kk_Contextual_Note)+kk_note_to_contextual_note (Kk_Note _ o' v' d' c' t') (Kk_Note n o v d c t) =+  let f i j = if i == j then Nothing else Just i+  in (t' + d', Kk_Contextual_Note (Just n) (f o o') (f v v') (f d d') (f c c') (f t t'))++-- | Elide octave modifier character.+kk_note_pp :: Kk_Note -> String+kk_note_pp (Kk_Note n o v d c t) = printf "%s%dv%dd%dc%dt%d" (kk_note_number_to_name n) o v d c t++kk_decontextualise_note :: Kk_Note -> Bool -> Kk_Contextual_Note -> Either Kk_Note Int+kk_decontextualise_note (Kk_Note _ o v d c t) is_par (Kk_Contextual_Note k' o' v' d' c' t') =+  let t'' = fromMaybe (if is_par then t else t + d) t'+  in case k' of+    Just k'' -> Left (Kk_Note k'' (fromMaybe o o') (fromMaybe v v') (fromMaybe d d') (fromMaybe c c') t'')+    Nothing -> Right t''++data Kk_Phrase = Kk_Phrase { kk_phrase_notes :: [Kk_Note], kk_phrase_length :: Int } deriving (Eq, Show)++-- | This should, but does not, append a trailing rest as required.+kk_phrase_pp :: Kk_Phrase -> String+kk_phrase_pp (Kk_Phrase n _) = unwords (map kk_note_pp n)++-- | Rests are elided, their duration is accounted for in the time of the following notetaken into account.+kk_decontextualise_phrase :: [(Kk_Contextual_Note, Bool)] -> Kk_Phrase+kk_decontextualise_phrase =+  let f r c p l =+        case l of+          [] -> Kk_Phrase (reverse r) (kk_note_time c + kk_note_duration c)+          (n,p'):l' ->+            case kk_decontextualise_note c p n of+              Left c' -> f (c' : r) c' p' l'+              Right t' -> f r (c {kk_note_time = t'}) p' l'+  in f [] kk_default_note True++-- | In addition to contextual note give end time of previous note, to allow for sequence (comma) notation.+kk_recontextualise_phrase :: Kk_Phrase -> [(Int, Kk_Contextual_Note)]+kk_recontextualise_phrase p =+  let f n0 n =+        case n of+          [] -> []+          n1 : n' -> kk_note_to_contextual_note n0 n1 : f n1 n'+  in case p of+    Kk_Phrase [] l -> [(0, kk_empty_contextual_rest l)]+    Kk_Phrase (n1 : n') _ ->+      let c1 = kk_note_to_initial_contextual_note n1+      in (0, c1) : f n1 n'++{- | Read KeyKit phrase constant.++> let rw = (\p -> (kk_phrase_pp p, kk_phrase_length p)) . kk_phrase_read+> rw "c" == ("c3v63d96c1t0",96)+> rw "c, r" == ("c3v63d96c1t0",192)+> rw "c, r, c3, r, p60" == ("c3v63d96c1t0 c3v63d96c1t192 c3v63d96c1t384",480)+> rw "c, e, g" == ("c3v63d96c1t0 e3v63d96c1t96 g3v63d96c1t192",288)+> rw "c2" == rw "co2"+-}+kk_phrase_read :: String -> Kk_Phrase+kk_phrase_read = kk_decontextualise_phrase . kk_parse kk_contextual_phrase_p++{- | Re-contextualise and print phrase.++> rw = kk_phrase_print . kk_phrase_read+> rw_id i = rw i == i+> rw_id "c"+> rw_id "c e g"+> rw_id "c , e , g"+> rw_id "c e g , c f a , c e g , c e- g"+> rw_id "c , e , g c4t384"+> rw "c, r, c3, r, p60" == "c ct192 ct384"+> rw "c , e , g c4t288" == "c , e , g , c4"+> rw "c r" == "c" -- ?+-}+kk_phrase_print :: Kk_Phrase -> String+kk_phrase_print = unwords . map kk_contextual_note_pp . kk_recontextualise_phrase
− Music/Theory/Time/Notation.hs 
@@ -1,465 +0,0 @@--- | 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 -}--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 = (MIN,SEC)---- | Minutes, seconds, centi-seconds as @(min,sec,csec)@-type MinCsec n = (n,n,n)---- | Type specialised.-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)-sec_to_minsec :: Integral n => n -> MinSec n-sec_to_minsec = flip divMod 60---- | Inverse of 'sec_minsec'.------ > minsec_to_sec (2,3) == 123-minsec_to_sec :: Num n => MinSec n -> n-minsec_to_sec (m,s) = m * 60 + s---- | 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))---- | 'minsec_binop' '-', assumes /q/ precedes /p/.------ > minsec_sub (2,35) (1,59) == (0,36)-minsec_sub :: Integral n => MinSec n -> MinSec n -> MinSec n-minsec_sub = minsec_binop (-)---- | 'minsec_binop' 'subtract', assumes /p/ precedes /q/.------ > minsec_diff (1,59) (2,35) == (0,36)-minsec_diff :: Integral n => MinSec n -> MinSec n -> MinSec n-minsec_diff = minsec_binop subtract---- | 'minsec_binop' '+'.------ > minsec_add (1,59) (2,35) == (4,34)-minsec_add :: Integral n => MinSec n -> MinSec n -> MinSec n-minsec_add = minsec_binop (+)---- | 'foldl' of 'minsec_add'------ > minsec_sum [(1,59),(2,35),(4,34)] == (9,08)-minsec_sum :: Integral n => [MinSec n] -> MinSec n-minsec_sum = foldl minsec_add (0,0)---- | '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-fsec_to_minsec = sec_to_minsec . round---- | 'MINSEC' pretty printer.------ > map (minsec_pp . fsec_to_minsec) [59,61] == ["00:59","01:01"]-minsec_pp :: MINSEC -> String-minsec_pp (m,s) = printf "%02d:%02d" m s---- * 'MinSec' parser.-minsec_parse :: (Num n,Read n) => String -> MinSec n-minsec_parse x =-    case splitOn ":" x of-      [m,s] -> (read m,read s)-      _ -> error "parse_minsec"---- * 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)]-fsec_to_mincsec :: FSEC -> MINCSEC-fsec_to_mincsec tm =-    let tm' = floor tm-        (m,s) = sec_to_minsec tm'-        cs = round ((tm - fromIntegral tm') * 100)-    in (m,s,cs)---- | Inverse of 'fsec_mincsec'.-mincsec_to_fsec :: Real n => MinCsec n -> FSEC-mincsec_to_fsec (m,s,cs) = realToFrac m * 60 + realToFrac s + (realToFrac cs / 100)---- > map (mincsec_to_csec . fsec_to_mincsec) [1,6+2/3,123.45] == [100,667,12345]-mincsec_to_csec :: Num n => MinCsec n -> n-mincsec_to_csec (m,s,cs) = m * 60 * 100 + s * 100 + cs---- | Centi-seconds to 'MinCsec'.------ > map csec_to_mincsec [123,12345] == [(0,1,23),(2,3,45)]-csec_to_mincsec :: Integral n => n -> MinCsec n-csec_to_mincsec csec =-    let (m,cs) = csec `divMod` 6000-        (s,cs') = cs `divMod` 100-    in (m,s,cs')---- | 'MINCSEC' pretty printer, concise mode omits centiseconds when zero.------ > map (mincsec_pp_opt True . fsec_to_mincsec) [1,60.5] == ["00:01","01:00.50"]-mincsec_pp_opt :: Bool -> MINCSEC -> String-mincsec_pp_opt concise (m,s,cs) =-  if concise && cs == 0-  then printf "%02d:%02d" m s-  else printf "%02d:%02d.%02d" m s cs---- | 'MINCSEC' pretty printer.------ > let r = ["00:01.00","00:06.67","02:03.45"]--- > map (mincsec_pp . fsec_to_mincsec) [1,6+2/3,123.45] == r-mincsec_pp :: MINCSEC -> String-mincsec_pp = mincsec_pp_opt False--mincsec_binop :: Integral t => (t -> t -> t) -> MinCsec t -> MinCsec t -> MinCsec t-mincsec_binop f p q = csec_to_mincsec (f (mincsec_to_csec p) (mincsec_to_csec q))---- * 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-span_pp f (t1,t2) = concat [f t1," - ",f t2]
Music/Theory/Time/Seq.hs view
@@ -9,12 +9,12 @@ import Safe {- safe -}  import qualified Data.List.Ordered as O {- data-ordlist -}-import qualified Data.Map as M {- containers -}+import qualified Data.Map as Map {- 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 -}-import qualified Music.Theory.Tuple as T {- hmt -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Math as T {- hmt-base -}+import qualified Music.Theory.Ord as T {- hmt-base -}+import qualified Music.Theory.Tuple as T {- hmt-base -}  -- * Types @@ -34,30 +34,36 @@  -- | 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.+-- These indicate the time the value conceptually takes, the time it actually takes, and the time to the next event.+-- If the sequence does not begin at time zero there must be an /empty/ value for /a/. type Pseq t a = [((t,t,t),a)]  -- | Time-point sequence.--- /t/ is the start-time of the value.+-- /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. -- /t/ is a duple of /start-time/ and /duration/.--- Holes exist where @st(n) + du(n)@ '<' @st(n+1)@.+-- Holes exist where /start-time(n) + duration(n) < start-time(n + 1)/. -- Overlaps exist where the same relation is '>'. type Wseq t a = [((t,t),a)] +-- | Event sequence.+-- /t/ is a triple of /start-time/, /duration/ and /length/.+-- /length/ isn't necessarily the time to the next event, though ordinarily it should not be greater than that interval.+type Eseq t a = [((t,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)+pseq_zip l o f = zip (zip3 l o f)  -- | Construct 'Wseq'. wseq_zip :: [t] -> [t] -> [a] -> Wseq t a-wseq_zip t d a = (zip (zip t d) a)+wseq_zip t d = zip (zip t d)  -- * Time span @@ -221,6 +227,10 @@ wseq_merge_set :: Ord t => [Wseq t a] -> Wseq t a wseq_merge_set = T.merge_set_by w_compare +-- | Merge considering only start times.+eseq_merge :: Ord t => Eseq t a -> Eseq t a -> Eseq t a+eseq_merge = O.mergeBy (compare `on` (T.t3_fst . fst))+ -- * Lookup  -- | Locate nodes to the left and right of indicated time.@@ -253,13 +263,16 @@ -- * Lseq  -- | Iterpolation type enumeration.-data Interpolation_T = None | Linear-                     deriving (Eq,Enum,Show)+data Interpolation_T =+  None | Linear+  deriving (Eq,Enum,Show)  -- | Variant of 'Tseq' where nodes have an 'Intepolation_T' value. type Lseq t a = Tseq (t,Interpolation_T) a --- | Linear interpolation.+{- | Linear interpolation.+     The Real constraint on t is to allow conversion from t to e (realToFrac).+-} lerp :: (Fractional t,Real t,Fractional e) => (t,e) -> (t,e) -> t -> e lerp (t0,e0) (t1,e1) t =     let n = t1 - t0@@ -290,11 +303,11 @@  -- | 'map' over time (/t/) data. seq_tmap :: (t1 -> t2) -> [(t1,a)] -> [(t2,a)]-seq_tmap f = map (\(p,q) -> (f p,q))+seq_tmap f = map (first f)  -- | 'map' over element (/e/) data. seq_map :: (e1 -> e2) -> [(t,e1)] -> [(t,e2)]-seq_map f = map (\(p,q) -> (p,f q))+seq_map f = map (second f)  -- | 'map' /t/ and /e/ simultaneously. --@@ -319,7 +332,7 @@ -- | 'mapMaybe' variant. seq_map_maybe :: (p -> Maybe q) -> [(t,p)] -> [(t,q)] seq_map_maybe f =-    let g (t,e) = maybe Nothing (\e' -> Just (t,e')) (f e)+    let g (t,e) = fmap (\e' -> (t,e')) (f e)     in mapMaybe g  -- | Variant of 'catMaybes'.@@ -350,11 +363,11 @@  -- | Apply /f/ at time points of 'Wseq'. wseq_tmap_st :: (t -> t) -> Wseq t a -> Wseq t a-wseq_tmap_st f = seq_tmap (bimap f id)+wseq_tmap_st f = seq_tmap (first f)  -- | Apply /f/ at durations of elements of 'Wseq'. wseq_tmap_dur :: (t -> t) -> Wseq t a -> Wseq t a-wseq_tmap_dur f = seq_tmap (bimap id f)+wseq_tmap_dur f = seq_tmap (second f)  -- * Partition @@ -362,11 +375,11 @@ -- a sequence into voices. seq_partition :: Ord v => (a -> v) -> [(t,a)] -> [(v,[(t,a)])] seq_partition voice sq =-    let assign m (t,a) = M.insertWith (++) (voice a) [(t,a)] m+    let assign m (t,a) = Map.insertWith (++) (voice a) [(t,a)] m         from_map = sortOn fst .-                   map (\(v,l) -> (v,reverse l)) .-                   M.toList-    in from_map (foldl assign M.empty sq)+                   map (second reverse) .+                   Map.toList+    in from_map (foldl assign Map.empty sq)  -- | Type specialised 'seq_partition'. --@@ -405,16 +418,17 @@ coalesce_m :: Monoid t => (t -> t -> Bool) -> [t] -> [t] coalesce_m dec_f = coalesce_f dec_f mappend --- | Form of 'coalesce_f' where the decision predicate is on the--- /element/, and a join function sums the /times/.------ > let r = [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')]--- > seq_coalesce (==) const (useq_to_dseq (1,"abbcccdde")) == r+-- | Form of 'coalesce_t' where the join predicate is on the /element/ only, the /times/ are summed.+coalesce_t :: Num t => ((t,a) -> (t,a) -> Bool) -> (a -> a -> a) -> [(t,a)] -> [(t,a)]+coalesce_t dec_f jn_f = coalesce_f dec_f (\(t1,a1) (t2,a2) -> (t1 + t2,jn_f a1 a2))++{- | Form of 'coalesce_f' where both the decision and join predicates are on the/element/, the /times/ are summed.++> let r = [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')]+> seq_coalesce (==) const (useq_to_dseq (1,"abbcccdde")) == r+-} seq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> [(t,a)] -> [(t,a)]-seq_coalesce dec_f jn_f =-    let dec_f' = dec_f `on` snd-        jn_f' (t1,a1) (t2,a2) = (t1 + t2,jn_f a1 a2)-    in coalesce_f dec_f' jn_f'+seq_coalesce dec_f jn_f = coalesce_t (dec_f `on` snd) jn_f  dseq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> Dseq t a -> Dseq t a dseq_coalesce = seq_coalesce@@ -429,7 +443,7 @@ -- > 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)+    let f l = let (t,e) = unzip l in (sum t,head e)     in map f . groupBy (eq `on` snd)  iseq_coalesce :: Num t => (a -> a -> Bool) -> (a -> a -> a) -> Iseq t a -> Iseq t a@@ -570,7 +584,7 @@   let recur sq =         case sq of           [] -> False-          e0:sq' -> if wseq_find_overlap_1 eq_fn e0 sq' then True else recur sq'+          e0:sq' -> wseq_find_overlap_1 eq_fn e0 sq' || recur sq'   in recur  {- | Remove overlaps by deleting any overlapping nodes.@@ -616,10 +630,11 @@ > 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 -}+> 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))-+> length sq == 186+> length (wseq_remove_overlaps_rw (==) id sq) == 183 -} 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 =@@ -834,6 +849,13 @@ 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 +{- | Variant where the final duration is discarded.++> dseq_to_tseq_discard 0 (zip [1,2,3,2,1] "abcde") == zip [0,1,3,6,8] "abcde"+-}+dseq_to_tseq_discard :: Num t => t -> Dseq t a -> Tseq t a+dseq_to_tseq_discard t0 = T.drop_last . dseq_to_tseq t0 undefined+ -- | 'Iseq' to 'Tseq', requires t0. -- -- > let r = zip [1,3,6,8,9] "abcde"@@ -870,6 +892,27 @@          [] -> []          t0:_ -> if t0 > 0 then (t0,empty) : zip d a else zip d a +{- | Variant that requires a final duration be provided, and that the Tseq have no end marker.++> let r = zip [1,2,3,2,9] "abcde"+> tseq_to_dseq_final_dur undefined 9 (zip [0,1,3,6,8] "abcde") == r+-}+tseq_to_dseq_final_dur :: (Ord t,Num t) => a -> t -> Tseq t a -> Dseq t a+tseq_to_dseq_final_dur empty dur sq =+  let (t,a) = unzip sq+      d = T.d_dx t ++ [dur]+  in case t of+       [] -> []+       t0:_ -> if t0 > 0 then (t0,empty) : zip d a else zip d a++{- | Variant that requires a total duration be provided, and that the Tseq have no end marker.++> let r = zip [1,2,3,2,7] "abcde"+> tseq_to_dseq_total_dur undefined 15 (zip [0,1,3,6,8] "abcde")+-}+tseq_to_dseq_total_dur :: (Ord t,Num t) => a -> t -> Tseq t a -> Dseq t a+tseq_to_dseq_total_dur empty dur sq = tseq_to_dseq_final_dur empty (dur - tseq_end sq) sq+ -- | 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 a /dur/@@ -888,6 +931,17 @@               Nothing -> T.d_dx t     in wseq_zip t d a +{- | Translate Tseq to Wseq using inter-offset times, up to indicated total duration, as element durations.++> let r = [((0,1),'a'),((1,2),'b'),((3,3),'c'),((6,2),'d'),((8,3),'e')]+> tseq_to_wseq_iot 11 (zip [0,1,3,6,8] "abcde") == r+-}+tseq_to_wseq_iot :: Num t => t -> Tseq t a -> Wseq t a+tseq_to_wseq_iot total_dur sq =+  let (t, e) = unzip sq+      d = zipWith (-) (tail t ++ [total_dur]) t+  in zip (zip t d) e+ -- | Tseq to Iseq. -- -- > tseq_to_iseq (zip [0,1,3,6,8,9] "abcde|") == zip [0,1,2,3,2,1] "abcde|"@@ -938,6 +992,9 @@          ((st,_),_):_ -> if st > 0 then (st,empty) : r else r          [] -> error "wseq_to_dseq" +eseq_to_wseq :: Eseq t a -> Wseq t a+eseq_to_wseq = let f ((t, d, _), e) = ((t, d), e) in map f+ -- * Measures  -- | Given a list of 'Dseq' (measures) convert to a list of 'Tseq' and@@ -960,7 +1017,7 @@ 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+    in map (\x -> wseq_tmap (first (+ x)) sq) t_sq  -- | Only finite 'Wseq' can be cycled, the resulting Wseq is infinite. --@@ -1046,3 +1103,12 @@  wseq_cat_maybes :: Wseq t (Maybe a) -> Wseq t a wseq_cat_maybes = seq_cat_maybes++-- * Maps++{- | Requires but does not check that there are no duplicate time points in Tseq.++> tseq_to_map [(0, 'a'), (0, 'b')] == tseq_to_map [(0, 'b')]+-}+tseq_to_map :: Ord t => Tseq t e -> Map.Map t e+tseq_to_map = Map.fromList
Music/Theory/Time_Signature.hs view
@@ -6,7 +6,7 @@  import Music.Theory.Duration import Music.Theory.Duration.Name-import Music.Theory.Duration.RQ+import Music.Theory.Duration.Rq import Music.Theory.Math  -- | A Time Signature is a /(numerator,denominator)/ pair.@@ -49,26 +49,26 @@       (6,2) -> [dotted_breve]       _ -> error ("ts_whole_note: " ++ show t) --- | Duration of measure in 'RQ'.+-- | Duration of measure in 'Rq'. -- -- > map ts_whole_note_rq [(3,8),(2,2)] == [3/2,4]-ts_whole_note_rq :: Time_Signature -> RQ+ts_whole_note_rq :: Time_Signature -> Rq ts_whole_note_rq = sum . map duration_to_rq . ts_whole_note --- | Duration, in 'RQ', of a measure of indicated 'Time_Signature'.+-- | Duration, in 'Rq', of a measure of indicated 'Time_Signature'. -- -- > map ts_rq [(3,4),(5,8)] == [3,5/2]-ts_rq :: Time_Signature -> RQ+ts_rq :: Time_Signature -> Rq ts_rq (n,d) = (4 * n) % d  -- | 'compare' 'on' 'ts_rq'. ts_compare :: Time_Signature -> Time_Signature -> Ordering ts_compare = compare `on` ts_rq --- | 'Time_Signature' derived from whole note duration in 'RQ' form.+-- | 'Time_Signature' derived from whole note duration in 'Rq' form. -- -- > map rq_to_ts [4,3/2,7/4,6] == [(4,4),(3,8),(7,16),(6,4)]-rq_to_ts :: RQ -> Time_Signature+rq_to_ts :: Rq -> Time_Signature rq_to_ts rq =     let n = numerator rq         d = denominator rq * 4@@ -81,7 +81,7 @@ -- > ts_divisions (2,2) == [2,2] -- > ts_divisions (1,1) == [4] -- > ts_divisions (7,4) == [1,1,1,1,1,1,1]-ts_divisions :: Time_Signature -> [RQ]+ts_divisions :: Time_Signature -> [Rq] ts_divisions (i,j) =     let k = fromIntegral i     in replicate k (recip (j % 4))@@ -123,23 +123,23 @@ -- | A composite time signature is a sequence of 'Time_Signature's. type Composite_Time_Signature = [Time_Signature] --- | The 'RQ' is the 'sum' of 'ts_rq' of the elements.+-- | The 'Rq' is the 'sum' of 'ts_rq' of the elements. -- -- > cts_rq [(3,4),(1,8)] == 3 + 1/2-cts_rq :: Composite_Time_Signature -> RQ+cts_rq :: Composite_Time_Signature -> Rq cts_rq = sum . map ts_rq  -- | The divisions are the 'concat' of the 'ts_divisions' of the -- elements. -- -- > cts_divisions [(3,4),(1,8)] == [1,1,1,1/2]-cts_divisions :: Composite_Time_Signature -> [RQ]+cts_divisions :: Composite_Time_Signature -> [Rq] cts_divisions = concatMap ts_divisions --- | Pulses are 1-indexed, RQ locations are 0-indexed.+-- | Pulses are 1-indexed, Rq locations are 0-indexed. -- -- > map (cts_pulse_to_rq [(2,4),(1,8),(1,4)]) [1 .. 4] == [0,1,2,2 + 1/2]-cts_pulse_to_rq :: Composite_Time_Signature -> Int -> RQ+cts_pulse_to_rq :: Composite_Time_Signature -> Int -> Rq cts_pulse_to_rq cts p =     let dv = cts_divisions cts     in sum (take (p - 1) dv)@@ -149,7 +149,7 @@ -- -- > let r = [(0,1),(1,1),(2,1/2),(2 + 1/2,1)] -- > in map (cts_pulse_to_rqw [(2,4),(1,8),(1,4)]) [1 .. 4] == r-cts_pulse_to_rqw :: Composite_Time_Signature -> Int -> (RQ,RQ)+cts_pulse_to_rqw :: Composite_Time_Signature -> Int -> (Rq,Rq) cts_pulse_to_rqw cts p = (cts_pulse_to_rq cts p,cts_divisions cts !! (p - 1))  -- * Rational Time Signatures@@ -158,11 +158,11 @@ -- the parts are 'Rational'. type Rational_Time_Signature = [(Rational,Rational)] --- | The 'sum' of the RQ of the elements.+-- | The 'sum' of the Rq of the elements. -- -- > rts_rq [(3,4),(1,8)] == 3 + 1/2 -- > rts_rq [(3/2,4),(1/2,8)] == 3/2 + 1/4-rts_rq :: Rational_Time_Signature -> RQ+rts_rq :: Rational_Time_Signature -> Rq rts_rq =     let f (n,d) = (4 * n) / d     in sum . map f@@ -171,7 +171,7 @@ -- -- > rts_divisions [(3,4),(1,8)] == [1,1,1,1/2] -- > rts_divisions [(3/2,4),(1/2,8)] == [1,1/2,1/4]-rts_divisions :: Rational_Time_Signature -> [[RQ]]+rts_divisions :: Rational_Time_Signature -> [[Rq]] rts_divisions =     let f (n,d) = let (ni,nf) = integral_and_fractional_parts n                       rq = recip (d / 4)@@ -181,14 +181,14 @@  -- > rts_derive [1,1,1,1/2] -- > rts_derive [1,1/2,1/4]-rts_derive :: [RQ] -> Rational_Time_Signature+rts_derive :: [Rq] -> Rational_Time_Signature rts_derive = let f rq = (rq,4) in map f --- | Pulses are 1-indexed, RQ locations are 0-indexed.+-- | Pulses are 1-indexed, Rq locations are 0-indexed. -- -- > map (rts_pulse_to_rq [(2,4),(1,8),(1,4)]) [1 .. 4] == [0,1,2,2 + 1/2] -- > map (rts_pulse_to_rq [(3/2,4),(1/2,8),(1/4,4)]) [1 .. 4] == [0,1,3/2,7/4]-rts_pulse_to_rq :: Rational_Time_Signature -> Int -> RQ+rts_pulse_to_rq :: Rational_Time_Signature -> Int -> Rq rts_pulse_to_rq rts p =     let dv = concat (rts_divisions rts)     in sum (take (p - 1) dv)@@ -198,5 +198,5 @@ -- -- > let r = [(0,1),(1,1),(2,1/2),(2 + 1/2,1)] -- > in map (rts_pulse_to_rqw [(2,4),(1,8),(1,4)]) [1 .. 4] == r-rts_pulse_to_rqw :: Rational_Time_Signature -> Int -> (RQ,RQ)+rts_pulse_to_rqw :: Rational_Time_Signature -> Int -> (Rq,Rq) rts_pulse_to_rqw ts p = (rts_pulse_to_rq ts p,concat (rts_divisions ts) !! (p - 1))
Music/Theory/Tuning.hs view
@@ -11,25 +11,33 @@  -- * Math/Floating --- | Fractional /midi/ note number to cycles per second, given frequency of ISO A4.+-- | Fractional /midi/ note number to cycles per second, given (k0,f0) pair.+--+-- > fmidi_to_cps_k0 (60,256) 69 == 430.5389646099018+fmidi_to_cps_k0 :: Floating a => (a,a) -> a -> a+fmidi_to_cps_k0 (k0,f0) i = f0 * (2 ** ((i - k0) * (1 / 12)))++-- | 'fmidi_to_cps_k0' with k0 of 69.+--+-- > fmidi_to_cps_f0 440 60 == 261.6255653005986 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 f0 = fmidi_to_cps_k0 (69,f0) --- | 'fmidi_to_cps_f0' 440.+-- | 'fmidi_to_cps_k0' (69,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 = fmidi_to_cps_k0 (69,440)  -- | /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_k0 :: (Integral i,Floating f) => (f,f) -> i -> f+midi_to_cps_k0 o = fmidi_to_cps_k0 o . fromIntegral --- | 'midi_to_cps_f0' 440.+-- | 'midi_to_cps_k0' (69,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+midi_to_cps = midi_to_cps_k0 (69,440)  -- | Convert from interval in cents to frequency ratio. --
+ Music/Theory/Tuning/Anamark.hs view
@@ -0,0 +1,106 @@+-- | Anamark tuning (TUN) files+--+-- <https://www.mark-henning.de/files/am/Tuning_File_V2_Doc.pdf>+module Music.Theory.Tuning.Anamark where++import Text.Printf {- base -}++import qualified Music.Theory.List as T++-- | Format section string+tun_sec :: String -> String+tun_sec = printf "[%s]"++-- | Format 'String' (text) attribute+tun_attr_txt :: (String,String) -> String+tun_attr_txt (k,v) = printf "%s = \"%s\"" k v++-- | Format 'Int' attribute+tun_attr_int :: (String,Int) -> String+tun_attr_int (k,v) = printf "%s = %d" k v++-- | Format 'Double' attribute+tun_attr_real :: (String,Double) -> String+tun_attr_real (k,v) = printf "%s = %f" k v++-- | TUN V.200 /Scale Begin/ (header) section.+tun_begin :: [String]+tun_begin =+  [tun_sec "Scale Begin"+  ,tun_attr_txt ("Format","AnaMark-TUN")+  ,tun_attr_int ("FormatVersion",200)+  ,tun_attr_txt ("FormatSpecs","http://www.mark-henning.de/eternity/tuningspecs.html")]++-- | Format /Info/ section given Name and ID (the only required fields).+--+-- > tun_info ("name","id")+tun_info :: (String,String) -> [String]+tun_info (nm,k) =+  [tun_sec "Info"+  ,tun_attr_txt ("Name",nm)+  ,tun_attr_txt ("ID",k)]++-- | Format /Tuning/ section given sequence of 128 integral cents values.+--+-- > tun_tuning [0,100.. 12700]+tun_tuning :: [Int] -> [String]+tun_tuning =+  let f k c = printf "note %d = %d" k c+  in (:) (tun_sec "Tuning") . zipWith f [0::Int .. 127]++-- | The default base frequency for /Exact Tuning/ (A4=440)+tun_f0_default :: Double+tun_f0_default = 8.1757989156437073336++-- | Format /Exact Tuning/ section given base frequency and sequence of 128 real cents values.+--+-- > tun_exact_tuning tun_f0_default [0,100.. 12700]+tun_exact_tuning :: Double -> [Double] -> [String]+tun_exact_tuning f0 =+  let f k c = printf "note %d = %f" k c+      hdr = [tun_sec "Exact Tuning"+            ,tun_attr_real ("BaseFreq",f0)]+  in (++) hdr  . zipWith f [0::Int .. 127]++{- | Format /Functional Tuning/ section given base frequency and sequence of 128 real cents values.++This simply sets note zero to /f0/ and increments each note by the difference from the previous note.++> tun_functional_tuning tun_f0_default [0,100.. 12700]+-}+tun_functional_tuning :: Double -> [Double] -> [String]+tun_functional_tuning f0 =+  let f k c = printf "note %d = \"#x=%d %% %f\"" k (k - 1) c+      hdr = [tun_sec "Functional Tuning"+            ,printf "note 0 = \"# %f\"" f0]+  in (++) hdr  . zipWith f [1::Int .. 127] . T.d_dx++-- | Format /Scale End/ section header.+tun_end :: [String]+tun_end =+  [tun_sec "Scale End"]++-- | Synonym for a list of strings.+type TUN = [String]++-- | Version 1 has just the /Tuning/ and /Exact Tuning/.+tun_from_cents_version_one :: (Double, [Double]) -> TUN+tun_from_cents_version_one (f0,c) =+  concat [tun_tuning (map round c)+         ,tun_exact_tuning f0 c]++-- | Version 2 files have, in addition, /Begin/, /Info/, /Functional Tuning/ and /End/ sections.+tun_from_cents_version_two :: (String,String) -> (Double, [Double]) -> TUN+tun_from_cents_version_two (nm,k) (f0,c) =+  concat [tun_begin+         ,tun_info (nm,k)+         ,tun_tuning (map round c)+         ,tun_exact_tuning f0 c+         ,tun_functional_tuning f0 c+         ,tun_end]++-- > t = tun_from_cents_version_one (tun_f0_default,[0,100 .. 12700])+-- > t = tun_from_cents_version_two ("equal-temperament-12","et12") (tun_f0_default,[0,100 .. 12700])+-- > tun_store "/home/rohan/et12.tun" t+tun_store :: FilePath -> TUN -> IO ()+tun_store fn = writeFile fn . unlines
− Music/Theory/Tuning/DB.hs 
@@ -1,74 +0,0 @@--- | DB of locally defined tunings, but for ordinary use see "Music.Theory.Tuning.Scala".-module Music.Theory.Tuning.DB where--import Data.List {- base -}--import Music.Theory.Tuning.Type--import Music.Theory.Tuning.Alves_1997-import Music.Theory.Tuning.Gann_1993-import Music.Theory.Tuning.Polansky_1978-import Music.Theory.Tuning.Polansky_1985c--import Music.Theory.Tuning.DB.Alves-import Music.Theory.Tuning.DB.Gann-import Music.Theory.Tuning.DB.Microtonal_Synthesis-import Music.Theory.Tuning.DB.Riley-import Music.Theory.Tuning.DB.Werckmeister---- | (last-name,first-name,title,year,hmt/tuning,scala/name)-type Named_Tuning = (String,String,String,String,Tuning,String)--named_tuning_t :: Named_Tuning -> Tuning-named_tuning_t (_,_,_,_,t,_) = t--tuning_db :: [Named_Tuning]-tuning_db =-    [("Aaron","Pietro","","1523",pietro_aaron_1523,"meanquar")-    ,("Alves","Bill","Slendro","",alves_slendro,"slendro_alves") -- 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,"") -- pyth_12 / zwolle-    ,("Harrison","Lou","16-tone","",lou_harrison_16,"harrison_16")-    ,("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") -- wurschmidt-    ,("Partch","Harry","43-tone","",partch_43,"partch_43")-    ,("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") -- bemetzrieder2-    ,("Werckmeister","Andreas","Werckmeister III","",werckmeister_iii,"werck3")-    ,("Werckmeister","Andreas","Werckmeister IV","",werckmeister_iv,"werck4")-    ,("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,"young1") -- young2-    ,("Zarlino","Gioseffo","","1588",zarlino_1588,"zarlino2") -- mersen_s3-    ,("","","JI/12 7-limit","",septimal_tritone_just_intonation,"ji_12")-    ,("","","ET/12","",tn_equal_temperament_12,"et12")-    ,("","","ET/19","",tn_equal_temperament_19,"et19")-    ,("","","ET/31","",tn_equal_temperament_31,"et13")-    ,("","","ET/53","",tn_equal_temperament_53,"et53")-    ,("","","ET/72","",tn_equal_temperament_72,"et72")-    ,("","","ET/96","",tn_equal_temperament_96,"et96")-    ,("","","Pythagorean/12","",pythagorean_12,"pyth_12") -- zwolle-    ]--tuning_db_lookup_scl :: String -> Maybe Tuning-tuning_db_lookup_scl nm = fmap named_tuning_t (find (\(_,_,_,_,_,scl) -> scl == nm) tuning_db)--{---import Music.Theory.Tuning.Scala-db <- scl_load_db-f n = take n . scl_db_query_cdiff_asc round db . sort . tn_cents_octave-f 2 pietro_aaron_1523-pp = mapM_ (putStrLn . unlines . scale_stat . snd)-mapM_ pp (map (f 2 . named_tuning_t) tuning_db)---}-
− Music/Theory/Tuning/DB/Alves.hs 
@@ -1,30 +0,0 @@--- | Bill Alves.-module Music.Theory.Tuning.DB.Alves where--import Music.Theory.Tuning.Type {- hmt -}--{- | 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 -}-    ,9/8,32/27-    ,81/64-    ,4/3,729/512-    ,3/2,6561/4096 {- 128/81 -}-    ,27/16,16/9-    ,243/128]---- | Ditone/pythagorean tuning, <http://www.billalves.com/porgitaro/ditonesettuning.html>------ > tn_divisions harrison_ditone == 12--- > tn_cents_i harrison_ditone == [0,114,204,294,408,498,612,702,816,906,996,1110]-harrison_ditone :: Tuning-harrison_ditone = Tuning (Left harrison_ditone_r) Nothing
− Music/Theory/Tuning/DB/Gann.hs 
@@ -1,130 +0,0 @@--- | Kyle Gann.-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]--- > 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 -- 5/4-    ,503.4,579.5-    ,696.8,772.6 -- 25/16-    ,889.7,1006.8-    ,1082.9]---- | Pietro Aaron (1523) meantone temperament, see--- <http://www.kylegann.com/histune.html>------ > 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"--- > 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) Nothing---- | Cents for 'thomas_young_1799'.------ > let c = [0,94,196,298,392,500,592,698,796,894,1000,1092]--- > map round thomas_young_1799_c == c-thomas_young_1799_c :: [Cents]-thomas_young_1799_c =-    [0,93.9-    ,195.8,297.8-    ,391.7-    ,499.9,591.9-    ,697.9,795.8-    ,893.8,999.8-    ,1091.8]---- | Thomas Young (1799), Well Temperament, <http://www.kylegann.com/histune.html>.------ > tn_cents_i thomas_young_1799 == [0,94,196,298,392,500,592,698,796,894,1000,1092]------ > scl <- scl_load "young2"--- > 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) Nothing---- | Ratios for 'zarlino'.------ > length zarlino_1588_r == 16-zarlino_1588_r :: [Rational]-zarlino_1588_r = [1/1,25/24,10/9,9/8,32/27,6/5,5/4,4/3,25/18,45/32,3/2,25/16,5/3,16/9,9/5,15/8]---- | Gioseffo Zarlino, 1588, see <http://www.kylegann.com/tuning.html>.------ > 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"--- > tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i zarlino_1588-zarlino_1588 :: Tuning-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]--- > map (round . ratio_to_cents) ben_johnston_mtp_1977_r == c-ben_johnston_mtp_1977_r :: [Rational]-ben_johnston_mtp_1977_r =-    [1,17/16-    ,9/8,19/16-    ,5/4-    ,21/16,11/8-    ,3/2,13/8-    ,27/16,7/4-    ,15/8]---- | Ben Johnston's \"Suite for Microtonal Piano\" (1977), see--- <http://www.kylegann.com/tuning.html>------ > 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) Nothing---- * Gann---- | Ratios for 'gann_arcana_xvi'.-gann_arcana_xvi_r :: [Rational]-gann_arcana_xvi_r =-    [1/1,21/20,16/15,9/8,7/6,6/5,11/9,5/4,21/16,4/3,27/20,7/5-    ,22/15,3/2,55/36,8/5,44/27,5/3,42/25,7/4,9/5,11/6,15/8,88/45]---- | Kyle Gann, _Arcana XVI_, see <http://www.kylegann.com/Arcana.html>.------ > let r = [0,84,112,204,267,316,347,386,471,498,520,583,663,702,734,814,845,884,898,969,1018,1049,1088,1161]--- > tn_cents_i gann_arcana_xvi == r-gann_arcana_xvi :: Tuning-gann_arcana_xvi = Tuning (Left gann_arcana_xvi_r) Nothing---- | Ratios for 'gann_superparticular'.-gann_superparticular_r :: [Rational]-gann_superparticular_r =-    [1/1,11/10,10/9,9/8,8/7,7/6,6/5,5/4,9/7,4/3-    ,11/8,7/5,10/7,3/2-    ,11/7,14/9,8/5,5/3,12/7,7/4,16/9,9/5]---- | Kyle Gann, _Superparticular_, see <http://www.kylegann.com/Super.html>.------ > 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]--- > tn_cents_i gann_superparticular == r------ > scl <- scl_load "gann_super"--- > tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i gann_superparticular-gann_superparticular :: Tuning-gann_superparticular = Tuning (Left gann_superparticular_r) Nothing
− Music/Theory/Tuning/DB/Microtonal_Synthesis.hs 
@@ -1,231 +0,0 @@--- | <http://www.microtonal-synthesis.com/scales.html>-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]-pythagorean_12_r =-    [1,2187/2048 {- 256/243 -}-    ,9/8,32/27-    ,81/64-    ,4/3,729/512-    ,3/2,6561/4096 {- 128/81 -}-    ,27/16,16/9-    ,243/128]---- | Pythagorean tuning, <http://www.microtonal-synthesis.com/scale_pythagorean.html>.------ > cents_i pythagorean_12 == [0,114,204,294,408,498,612,702,816,906,996,1110]------ > scl <- scl_load "pyth_12"--- > cents_i (scale_tuning 0.1 scl) == cents_i pythagorean_12-pythagorean_12 :: Tuning-pythagorean_12 = Tuning (Left pythagorean_12_r) Nothing---- | Ratios for 'five_limit_tuning'.------ > let c = [0,112,204,316,386,498,590,702,814,884,996,1088]--- > in map (round . ratio_to_cents) five_limit_tuning_r == c-five_limit_tuning_r :: [Rational]-five_limit_tuning_r =-    [1,16/15-    ,9/8,6/5-    ,5/4-    ,4/3,45/32 {- 64/45 -}-    ,3/2,8/5-    ,5/3,16/9 {- 9/5 -}-    ,15/8]---- | Five-limit tuning (five limit just intonation), Alexander Malcolm's Monochord (1721).------ > cents_i five_limit_tuning == [0,112,204,316,386,498,590,702,814,884,996,1088]------ > scl <- scl_load "malcolm"--- > cents_i (scale_tuning 0.1 scl) == cents_i five_limit_tuning-five_limit_tuning :: Tuning-five_limit_tuning = Tuning (Left five_limit_tuning_r) Nothing---- | Ratios for 'septimal_tritone_just_intonation'.------ > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088]--- > in map (round . ratio_to_cents) septimal_tritone_just_intonation == c-septimal_tritone_just_intonation_r :: [Rational]-septimal_tritone_just_intonation_r =-    [1,16/15-    ,9/8,6/5-    ,5/4-    ,4/3,7/5-    ,3/2,8/5-    ,5/3,9/5-    ,15/8]---- | Septimal tritone Just Intonation, see--- <http://www.microtonal-synthesis.com/scale_just_intonation.html>------ > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088]--- > in cents_i septimal_tritone_just_intonation == c------ > scl <- scl_load "ji_12"--- > cents_i (scale_tuning 0.1 scl) == cents_i septimal_tritone_just_intonation-septimal_tritone_just_intonation :: Tuning-septimal_tritone_just_intonation = Tuning (Left septimal_tritone_just_intonation_r) Nothing---- | Ratios for 'seven_limit_just_intonation'.------ > let c = [0,112,204,316,386,498,583,702,814,884,969,1088]--- > in map (round . ratio_to_cents) seven_limit_just_intonation == c-seven_limit_just_intonation_r :: [Rational]-seven_limit_just_intonation_r =-    [1,16/15-    ,9/8,6/5-    ,5/4-    ,4/3,7/5-    ,3/2,8/5-    ,5/3,7/4-    ,15/8]---- | Seven limit Just Intonation.------ > cents_i seven_limit_just_intonation == [0,112,204,316,386,498,583,702,814,884,969,1088]-seven_limit_just_intonation :: Tuning-seven_limit_just_intonation = Tuning (Left seven_limit_just_intonation_r) Nothing---- | Approximate ratios for 'kirnberger_iii'.------ > let c = [0,90,193,294,386,498,590,697,792,890,996,1088]--- > in map (round.to_cents) kirnberger_iii_ar == c-kirnberger_iii_ar :: [Approximate_Ratio]-kirnberger_iii_ar =-    [1,256/243-    ,sqrt 5 / 2,32/27-    ,5/4-    ,4/3,45/32-    ,5 ** 0.25,128/81-    ,(5 ** 0.75)/2,16/9-    ,15/8]---- | <http://www.microtonal-synthesis.com/scale_kirnberger.html>.------ > cents_i kirnberger_iii == [0,90,193,294,386,498,590,697,792,890,996,1088]------ > 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)) Nothing---- > let c = [0,94,196,298,392,502,592,698,796,894,1000,1090]--- > in map round vallotti_c == c-vallotti_c :: [Cents]-vallotti_c =-    [0.0,94.135-    ,196.09,298.045-    ,392.18-    ,501.955,592.18-    ,698.045,796.09-    ,894.135,1000.0-    ,1090.225]---- | Vallotti & Young scale (Vallotti version), see--- <http://www.microtonal-synthesis.com/scale_vallotti_young.html>.------ > cents_i vallotti == [0,94,196,298,392,502,592,698,796,894,1000,1090]------ > scl <- scl_load "vallotti"--- > cents_i (scale_tuning 0.1 scl) == cents_i vallotti-vallotti :: Tuning-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-mayumi_tsuda_r :: [Rational]-mayumi_tsuda_r =-    [1,14/13-    ,13/12,16/13-    ,13/10-    ,18/13,13/9-    ,20/13,13/8-    ,22/13,13/7-    ,208/105]---- | Mayumi Tsuda 13-limit Just Intonation scale,--- <http://www.microtonal-synthesis.com/scale_reinhard.html>.------ > cents_i mayumi_tsuda == [0,128,139,359,454,563,637,746,841,911,1072,1183]------ > scl <- scl_load "tsuda13"--- > cents_i (scale_tuning 0.1 scl) == cents_i mayumi_tsuda-mayumi_tsuda :: Tuning-mayumi_tsuda = Tuning (Left mayumi_tsuda_r) Nothing---- | Ratios for 'lou_harrison_16'.------ > length lou_harrison_16_r == 16------ > let c = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088]--- > in map (round . ratio_to_cents) lou_harrison_16_r == c-lou_harrison_16_r :: [Rational]-lou_harrison_16_r =-    [1,16/15-    ,10/9,8/7-    ,7/6,6/5,5/4-    ,4/3-    ,17/12-    ,3/2-    ,8/5,5/3,12/7-    ,7/4,9/5,15/8]---- | Lou Harrison 16 tone Just Intonation scale, see--- <http://www.microtonal-synthesis.com/scale_harrison_16.html>------ > let r = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088]--- > in cents_i lou_harrison_16 == r------ > import Music.Theory.Tuning.Scala--- > scl <- scl_load "harrison_16"--- > cents_i (scale_tuning 0.1 scl) == cents_i lou_harrison_16-lou_harrison_16 :: Tuning-lou_harrison_16 = Tuning (Left lou_harrison_16_r) Nothing---- | Ratios for 'partch_43'.-partch_43_r :: [Rational]-partch_43_r =-    [1,81/80,33/32,21/20,16/15,12/11,11/10,10/9,9/8,8/7-    ,7/6,32/27,6/5,11/9,5/4,14/11,9/7-    ,21/16,4/3,27/20-    ,11/8,7/5,10/7,16/11-    ,40/27,3/2,32/21,14/9,11/7,8/5,18/11,5/3,27/16,12/7-    ,7/4,16/9,9/5,20/11,11/6,15/8,40/21,64/33,160/81]---- | Harry Partch 43 tone scale, see--- <http://www.microtonal-synthesis.com/scale_partch.html>------ > cents_i partch_43 == [0,22,53,84,112,151,165--- >                      ,182,204,231,267,294,316--- >                      ,347,386,418,435--- >                      ,471,498,520,551,583,617,649--- >                      ,680,702,729,765,782,814,853,884,906,933--- >                      ,969,996,1018,1035,1049,1088,1116,1147,1178]------ > 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) Nothing---- | Ratios for 'ben_johnston_25'.-ben_johnston_25_r :: [Rational]-ben_johnston_25_r =-    [1/1,25/24,135/128,16/15,10/9-    ,9/8,75/64,6/5,5/4,81/64-    ,32/25,4/3,27/20,45/32,36/25-    ,3/2,25/16,8/5,5/3,27/16-    ,225/128,16/9,9/5,15/8,48/25]---- | Ben Johnston 25 note just enharmonic scale, see--- <http://www.microtonal-synthesis.com/scale_johnston_25.html>------ > 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) Nothing
− Music/Theory/Tuning/DB/Riley.hs 
@@ -1,22 +0,0 @@--- | Terry Riley.-module Music.Theory.Tuning.DB.Riley where--import Music.Theory.Tuning.Type {- hmt -}---- | Ratios for 'riley_albion'.------ > let r = [0,112,204,316,386,498,610,702,814,884,996,1088]--- > in map (round . ratio_to_cents) riley_albion_r == r-riley_albion_r :: [Rational]-riley_albion_r = [1/1,16/15,9/8,6/5,5/4,4/3,64/45,3/2,8/5,5/3,16/9,15/8]---- | Riley's five-limit tuning as used in _The Harp of New Albion_,--- see <http://www.ex-tempore.org/Volx1/hudson/hudson.htm>.------ > cents_i riley_albion == [0,112,204,316,386,498,610,702,814,884,996,1088]------ > import Music.Theory.Tuning.Scala--- > scl <- scl_load "riley_albion"--- > cents_i (scale_tuning 0.01 scl) == cents_i riley_albion-riley_albion :: Tuning-riley_albion = Tuning (Left riley_albion_r) Nothing
− Music/Theory/Tuning/DB/Werckmeister.hs 
@@ -1,118 +0,0 @@--- | Andreas Werckmeister (1645-1706).-module Music.Theory.Tuning.DB.Werckmeister where--import Music.Theory.Tuning {- hmt -}-import Music.Theory.Tuning.Type {- hmt -}---- | Approximate ratios for 'werckmeister_iii'.------ > let c = [0,90,192,294,390,498,588,696,792,888,996,1092]--- > in map (round . ratio_to_cents) werckmeister_iii_ar == c-werckmeister_iii_ar :: [Approximate_Ratio]-werckmeister_iii_ar =-    let c0 = 2 ** (1/2)-        c1 = 2 ** (1/4)-        c2 = 8 ** (1/4)-    in [1,256/243-       ,64/81 * c0,32/27-       ,256/243 * c1-       ,4/3,1024/729-       ,8/9 * c2,128/81-       ,1024/729 * c1,16/9-       ,128/81 * c1]---- | Cents for 'werckmeister_iii'.-werckmeister_iii_ar_c :: [Cents]-werckmeister_iii_ar_c = map approximate_ratio_to_cents werckmeister_iii_ar---- | Werckmeister III, Andreas Werckmeister (1645-1706)------ > cents_i werckmeister_iii == [0,90,192,294,390,498,588,696,792,888,996,1092]------ > import Music.Theory.Tuning.Scala--- > scl <- scl_load "werck3"--- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iii-werckmeister_iii :: Tuning-werckmeister_iii = Tuning (Right werckmeister_iii_ar_c) Nothing---- | Approximate ratios for 'werckmeister_iv'.------ > let c = [0,82,196,294,392,498,588,694,784,890,1004,1086]--- > in map (round . ratio_to_cents) werckmeister_iv_ar == c-werckmeister_iv_ar :: [Approximate_Ratio]-werckmeister_iv_ar =-    let c0 = 2 ** (1/3)-        c1 = 4 ** (1/3)-    in [1,16384/19683 * c0-       ,8/9 * c0,32/27-       ,64/81 * c1-       ,4/3,1024/729-       ,32/27 * c0,8192/6561 * c0-       ,256/243 * c1,9/(4*c0)-       ,4096/2187]---- | Cents for 'werckmeister_iv'.-werckmeister_iv_c :: [Cents]-werckmeister_iv_c = map approximate_ratio_to_cents werckmeister_iv_ar---- | Werckmeister IV, Andreas Werckmeister (1645-1706)------ > cents_i werckmeister_iv == [0,82,196,294,392,498,588,694,784,890,1004,1086]------ > scl <- scl_load "werck4"--- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iv-werckmeister_iv :: Tuning-werckmeister_iv = Tuning (Right werckmeister_iv_c) Nothing---- | Approximate ratios for 'werckmeister_v'.------ > let c = [0,96,204,300,396,504,600,702,792,900,1002,1098]--- > in map (round . ratio_to_cents) werckmeister_v_ar == c-werckmeister_v_ar :: [Approximate_Ratio]-werckmeister_v_ar =-    let c0 = 2 ** (1/4)-        c1 = 2 ** (1/2)-        c2 = 8 ** (1/4)-    in [1,8/9 * c0-       ,9/8,c0-       ,8/9 * c1-       ,9/8 * c0,c1-       ,3/2,128/81-       ,c2,3/c2-       ,4/3 * c1]---- | Cents for 'werckmeister_v'.-werckmeister_v_c :: [Cents]-werckmeister_v_c = map approximate_ratio_to_cents werckmeister_v_ar---- | Werckmeister V, Andreas Werckmeister (1645-1706)------ > cents_i werckmeister_v == [0,96,204,300,396,504,600,702,792,900,1002,1098]------ > scl <- scl_load "werck5"--- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_v-werckmeister_v :: Tuning-werckmeister_v = Tuning (Right werckmeister_v_c) Nothing---- | Ratios for 'werckmeister_vi', with supposed correction of 28/25 to 49/44.------ > let c = [0,91,186,298,395,498,595,698,793,893,1000,1097]--- > in map (round . ratio_to_cents) werckmeister_vi_r == c-werckmeister_vi_r :: [Rational]-werckmeister_vi_r =-    [1,98/93-    ,49/44 {- 28/25 -},196/165-    ,49/39-    ,4/3,196/139-    ,196/131,49/31-    ,196/117,98/55-    ,49/26]---- | Werckmeister VI, Andreas Werckmeister (1645-1706)------ > cents_i werckmeister_vi == [0,91,186,298,395,498,595,698,793,893,1000,1097]------ > scl <- scl_load "werck6"--- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_vi-werckmeister_vi :: Tuning-werckmeister_vi = Tuning (Left werckmeister_vi_r) Nothing
+ Music/Theory/Tuning/Db.hs view
@@ -0,0 +1,74 @@+-- | Db of locally defined tunings, but for ordinary use see "Music.Theory.Tuning.Scala".+module Music.Theory.Tuning.Db where++import Data.List {- base -}++import Music.Theory.Tuning.Type++import Music.Theory.Tuning.Alves_1997+import Music.Theory.Tuning.Gann_1993+import Music.Theory.Tuning.Polansky_1978+import Music.Theory.Tuning.Polansky_1985c++import Music.Theory.Tuning.Db.Alves+import Music.Theory.Tuning.Db.Gann+import Music.Theory.Tuning.Db.Microtonal_Synthesis+import Music.Theory.Tuning.Db.Riley+import Music.Theory.Tuning.Db.Werckmeister++-- | (last-name,first-name,title,year,hmt/tuning,scala/name)+type Named_Tuning = (String,String,String,String,Tuning,String)++named_tuning_t :: Named_Tuning -> Tuning+named_tuning_t (_,_,_,_,t,_) = t++tuning_db :: [Named_Tuning]+tuning_db =+    [("Aaron","Pietro","","1523",pietro_aaron_1523,"meanquar")+    ,("Alves","Bill","Slendro","",alves_slendro,"slendro_alves") -- 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,"") -- pyth_12 / zwolle+    ,("Harrison","Lou","16-tone","",lou_harrison_16,"harrison_16")+    ,("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") -- wurschmidt+    ,("Partch","Harry","43-tone","",partch_43,"partch_43")+    ,("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") -- bemetzrieder2+    ,("Werckmeister","Andreas","Werckmeister III","",werckmeister_iii,"werck3")+    ,("Werckmeister","Andreas","Werckmeister IV","",werckmeister_iv,"werck4")+    ,("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,"young1") -- young2+    ,("Zarlino","Gioseffo","","1588",zarlino_1588,"zarlino2") -- mersen_s3+    ,("","","JI/12 7-limit","",septimal_tritone_just_intonation,"ji_12")+    ,("","","ET/12","",tn_equal_temperament_12,"et12")+    ,("","","ET/19","",tn_equal_temperament_19,"et19")+    ,("","","ET/31","",tn_equal_temperament_31,"et13")+    ,("","","ET/53","",tn_equal_temperament_53,"et53")+    ,("","","ET/72","",tn_equal_temperament_72,"et72")+    ,("","","ET/96","",tn_equal_temperament_96,"et96")+    ,("","","Pythagorean/12","",pythagorean_12,"pyth_12") -- zwolle+    ]++tuning_db_lookup_scl :: String -> Maybe Tuning+tuning_db_lookup_scl nm = fmap named_tuning_t (find (\(_,_,_,_,_,scl) -> scl == nm) tuning_db)++{-++import Music.Theory.Tuning.Scala+db <- scl_load_db+f n = take n . scl_db_query_cdiff_asc round db . sort . tn_cents_octave+f 2 pietro_aaron_1523+pp = mapM_ (putStrLn . unlines . scale_stat . snd)+mapM_ pp (map (f 2 . named_tuning_t) tuning_db)++-}+
+ Music/Theory/Tuning/Db/Alves.hs view
@@ -0,0 +1,30 @@+-- | Bill Alves.+module Music.Theory.Tuning.Db.Alves where++import Music.Theory.Tuning.Type {- hmt -}++{- | 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 -}+    ,9/8,32/27+    ,81/64+    ,4/3,729/512+    ,3/2,6561/4096 {- 128/81 -}+    ,27/16,16/9+    ,243/128]++-- | Ditone/pythagorean tuning, <http://www.billalves.com/porgitaro/ditonesettuning.html>+--+-- > tn_divisions harrison_ditone == 12+-- > tn_cents_i harrison_ditone == [0,114,204,294,408,498,612,702,816,906,996,1110]+harrison_ditone :: Tuning+harrison_ditone = Tuning (Left harrison_ditone_r) Nothing
+ Music/Theory/Tuning/Db/Gann.hs view
@@ -0,0 +1,130 @@+-- | Kyle Gann.+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]+-- > 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 -- 5/4+    ,503.4,579.5+    ,696.8,772.6 -- 25/16+    ,889.7,1006.8+    ,1082.9]++-- | Pietro Aaron (1523) meantone temperament, see+-- <http://www.kylegann.com/histune.html>+--+-- > 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"+-- > 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) Nothing++-- | Cents for 'thomas_young_1799'.+--+-- > let c = [0,94,196,298,392,500,592,698,796,894,1000,1092]+-- > map round thomas_young_1799_c == c+thomas_young_1799_c :: [Cents]+thomas_young_1799_c =+    [0,93.9+    ,195.8,297.8+    ,391.7+    ,499.9,591.9+    ,697.9,795.8+    ,893.8,999.8+    ,1091.8]++-- | Thomas Young (1799), Well Temperament, <http://www.kylegann.com/histune.html>.+--+-- > tn_cents_i thomas_young_1799 == [0,94,196,298,392,500,592,698,796,894,1000,1092]+--+-- > scl <- scl_load "young2"+-- > 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) Nothing++-- | Ratios for 'zarlino'.+--+-- > length zarlino_1588_r == 16+zarlino_1588_r :: [Rational]+zarlino_1588_r = [1,25/24,10/9,9/8,32/27,6/5,5/4,4/3,25/18,45/32,3/2,25/16,5/3,16/9,9/5,15/8]++-- | Gioseffo Zarlino, 1588, see <http://www.kylegann.com/tuning.html>.+--+-- > 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"+-- > tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i zarlino_1588+zarlino_1588 :: Tuning+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]+-- > map (round . ratio_to_cents) ben_johnston_mtp_1977_r == c+ben_johnston_mtp_1977_r :: [Rational]+ben_johnston_mtp_1977_r =+    [1,17/16+    ,9/8,19/16+    ,5/4+    ,216,11/8+    ,3/2,13/8+    ,27/16,7/4+    ,15/8]++-- | Ben Johnston's \"Suite for Microtonal Piano\" (1977), see+-- <http://www.kylegann.com/tuning.html>+--+-- > 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) Nothing++-- * Gann++-- | Ratios for 'gann_arcana_xvi'.+gann_arcana_xvi_r :: [Rational]+gann_arcana_xvi_r =+    [1,21/20,16/15,9/8,7/6,6/5,11/9,5/4,216,4/3,27/20,7/5+    ,22/15,3/2,55/36,8/5,44/27,5/3,42/25,7/4,9/5,11/6,15/8,88/45]++-- | Kyle Gann, _Arcana XVI_, see <http://www.kylegann.com/Arcana.html>.+--+-- > let r = [0,84,112,204,267,316,347,386,471,498,520,583,663,702,734,814,845,884,898,969,1018,1049,1088,1161]+-- > tn_cents_i gann_arcana_xvi == r+gann_arcana_xvi :: Tuning+gann_arcana_xvi = Tuning (Left gann_arcana_xvi_r) Nothing++-- | Ratios for 'gann_superparticular'.+gann_superparticular_r :: [Rational]+gann_superparticular_r =+    [1,110,10/9,9/8,8/7,7/6,6/5,5/4,9/7,4/3+    ,11/8,7/5,10/7,3/2+    ,11/7,14/9,8/5,5/3,12/7,7/4,16/9,9/5]++-- | Kyle Gann, _Superparticular_, see <http://www.kylegann.com/Super.html>.+--+-- > 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]+-- > tn_cents_i gann_superparticular == r+--+-- > scl <- scl_load "gann_super"+-- > tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i gann_superparticular+gann_superparticular :: Tuning+gann_superparticular = Tuning (Left gann_superparticular_r) Nothing
+ Music/Theory/Tuning/Db/Microtonal_Synthesis.hs view
@@ -0,0 +1,231 @@+-- | <http://www.microtonal-synthesis.com/scales.html>+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]+pythagorean_12_r =+    [1,2187/2048 {- 256/243 -}+    ,9/8,32/27+    ,81/64+    ,4/3,729/512+    ,3/2,6561/4096 {- 128/81 -}+    ,27/16,16/9+    ,243/128]++-- | Pythagorean tuning, <http://www.microtonal-synthesis.com/scale_pythagorean.html>.+--+-- > cents_i pythagorean_12 == [0,114,204,294,408,498,612,702,816,906,996,1110]+--+-- > scl <- scl_load "pyth_12"+-- > cents_i (scale_tuning 0.1 scl) == cents_i pythagorean_12+pythagorean_12 :: Tuning+pythagorean_12 = Tuning (Left pythagorean_12_r) Nothing++-- | Ratios for 'five_limit_tuning'.+--+-- > let c = [0,112,204,316,386,498,590,702,814,884,996,1088]+-- > in map (round . ratio_to_cents) five_limit_tuning_r == c+five_limit_tuning_r :: [Rational]+five_limit_tuning_r =+    [1,16/15+    ,9/8,6/5+    ,5/4+    ,4/3,45/32 {- 64/45 -}+    ,3/2,8/5+    ,5/3,16/9 {- 9/5 -}+    ,15/8]++-- | Five-limit tuning (five limit just intonation), Alexander Malcolm's Monochord (1721).+--+-- > cents_i five_limit_tuning == [0,112,204,316,386,498,590,702,814,884,996,1088]+--+-- > scl <- scl_load "malcolm"+-- > cents_i (scale_tuning 0.1 scl) == cents_i five_limit_tuning+five_limit_tuning :: Tuning+five_limit_tuning = Tuning (Left five_limit_tuning_r) Nothing++-- | Ratios for 'septimal_tritone_just_intonation'.+--+-- > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088]+-- > in map (round . ratio_to_cents) septimal_tritone_just_intonation == c+septimal_tritone_just_intonation_r :: [Rational]+septimal_tritone_just_intonation_r =+    [1,16/15+    ,9/8,6/5+    ,5/4+    ,4/3,7/5+    ,3/2,8/5+    ,5/3,9/5+    ,15/8]++-- | Septimal tritone Just Intonation, see+-- <http://www.microtonal-synthesis.com/scale_just_intonation.html>+--+-- > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088]+-- > in cents_i septimal_tritone_just_intonation == c+--+-- > scl <- scl_load "ji_12"+-- > cents_i (scale_tuning 0.1 scl) == cents_i septimal_tritone_just_intonation+septimal_tritone_just_intonation :: Tuning+septimal_tritone_just_intonation = Tuning (Left septimal_tritone_just_intonation_r) Nothing++-- | Ratios for 'seven_limit_just_intonation'.+--+-- > let c = [0,112,204,316,386,498,583,702,814,884,969,1088]+-- > in map (round . ratio_to_cents) seven_limit_just_intonation == c+seven_limit_just_intonation_r :: [Rational]+seven_limit_just_intonation_r =+    [1,16/15+    ,9/8,6/5+    ,5/4+    ,4/3,7/5+    ,3/2,8/5+    ,5/3,7/4+    ,15/8]++-- | Seven limit Just Intonation.+--+-- > cents_i seven_limit_just_intonation == [0,112,204,316,386,498,583,702,814,884,969,1088]+seven_limit_just_intonation :: Tuning+seven_limit_just_intonation = Tuning (Left seven_limit_just_intonation_r) Nothing++-- | Approximate ratios for 'kirnberger_iii'.+--+-- > let c = [0,90,193,294,386,498,590,697,792,890,996,1088]+-- > in map (round.to_cents) kirnberger_iii_ar == c+kirnberger_iii_ar :: [Approximate_Ratio]+kirnberger_iii_ar =+    [1,256/243+    ,sqrt 5 / 2,32/27+    ,5/4+    ,4/3,45/32+    ,5 ** 0.25,128/81+    ,(5 ** 0.75)/2,16/9+    ,15/8]++-- | <http://www.microtonal-synthesis.com/scale_kirnberger.html>.+--+-- > cents_i kirnberger_iii == [0,90,193,294,386,498,590,697,792,890,996,1088]+--+-- > 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)) Nothing++-- > let c = [0,94,196,298,392,502,592,698,796,894,1000,1090]+-- > in map round vallotti_c == c+vallotti_c :: [Cents]+vallotti_c =+    [0.0,94.135+    ,196.09,298.045+    ,392.18+    ,501.955,592.18+    ,698.045,796.09+    ,894.135,1000.0+    ,1090.225]++-- | Vallotti & Young scale (Vallotti version), see+-- <http://www.microtonal-synthesis.com/scale_vallotti_young.html>.+--+-- > cents_i vallotti == [0,94,196,298,392,502,592,698,796,894,1000,1090]+--+-- > scl <- scl_load "vallotti"+-- > cents_i (scale_tuning 0.1 scl) == cents_i vallotti+vallotti :: Tuning+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+mayumi_tsuda_r :: [Rational]+mayumi_tsuda_r =+    [1,14/13+    ,13/12,16/13+    ,13/10+    ,18/13,13/9+    ,20/13,13/8+    ,22/13,13/7+    ,208/105]++-- | Mayumi Tsuda 13-limit Just Intonation scale,+-- <http://www.microtonal-synthesis.com/scale_reinhard.html>.+--+-- > cents_i mayumi_tsuda == [0,128,139,359,454,563,637,746,841,911,1072,1183]+--+-- > scl <- scl_load "tsuda13"+-- > cents_i (scale_tuning 0.1 scl) == cents_i mayumi_tsuda+mayumi_tsuda :: Tuning+mayumi_tsuda = Tuning (Left mayumi_tsuda_r) Nothing++-- | Ratios for 'lou_harrison_16'.+--+-- > length lou_harrison_16_r == 16+--+-- > let c = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088]+-- > in map (round . ratio_to_cents) lou_harrison_16_r == c+lou_harrison_16_r :: [Rational]+lou_harrison_16_r =+    [1,16/15+    ,10/9,8/7+    ,7/6,6/5,5/4+    ,4/3+    ,17/12+    ,3/2+    ,8/5,5/3,12/7+    ,7/4,9/5,15/8]++-- | Lou Harrison 16 tone Just Intonation scale, see+-- <http://www.microtonal-synthesis.com/scale_harrison_16.html>+--+-- > let r = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088]+-- > in cents_i lou_harrison_16 == r+--+-- > import Music.Theory.Tuning.Scala+-- > scl <- scl_load "harrison_16"+-- > cents_i (scale_tuning 0.1 scl) == cents_i lou_harrison_16+lou_harrison_16 :: Tuning+lou_harrison_16 = Tuning (Left lou_harrison_16_r) Nothing++-- | Ratios for 'partch_43'.+partch_43_r :: [Rational]+partch_43_r =+    [1,81/80,33/32,21/20,16/15,12/11,110,10/9,9/8,8/7+    ,7/6,32/27,6/5,11/9,5/4,14/11,9/7+    ,216,4/3,27/20+    ,11/8,7/5,10/7,16/11+    ,40/27,3/2,32/21,14/9,11/7,8/5,18/11,5/3,27/16,12/7+    ,7/4,16/9,9/5,20/11,11/6,15/8,40/21,64/33,160/81]++-- | Harry Partch 43 tone scale, see+-- <http://www.microtonal-synthesis.com/scale_partch.html>+--+-- > cents_i partch_43 == [0,22,53,84,112,151,165+-- >                      ,182,204,231,267,294,316+-- >                      ,347,386,418,435+-- >                      ,471,498,520,551,583,617,649+-- >                      ,680,702,729,765,782,814,853,884,906,933+-- >                      ,969,996,1018,1035,1049,1088,1116,1147,1178]+--+-- > 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) Nothing++-- | Ratios for 'ben_johnston_25'.+ben_johnston_25_r :: [Rational]+ben_johnston_25_r =+    [1,25/24,135/128,16/15,10/9+    ,9/8,75/64,6/5,5/4,81/64+    ,32/25,4/3,27/20,45/32,36/25+    ,3/2,25/16,8/5,5/3,27/16+    ,225/128,16/9,9/5,15/8,48/25]++-- | Ben Johnston 25 note just enharmonic scale, see+-- <http://www.microtonal-synthesis.com/scale_johnston_25.html>+--+-- > 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) Nothing
+ Music/Theory/Tuning/Db/Riley.hs view
@@ -0,0 +1,22 @@+-- | Terry Riley.+module Music.Theory.Tuning.Db.Riley where++import Music.Theory.Tuning.Type {- hmt -}++-- | Ratios for 'riley_albion'.+--+-- > let r = [0,112,204,316,386,498,610,702,814,884,996,1088]+-- > in map (round . ratio_to_cents) riley_albion_r == r+riley_albion_r :: [Rational]+riley_albion_r = [1,16/15,9/8,6/5,5/4,4/3,64/45,3/2,8/5,5/3,16/9,15/8]++-- | Riley's five-limit tuning as used in _The Harp of New Albion_,+-- see <http://www.ex-tempore.org/Volx1/hudson/hudson.htm>.+--+-- > cents_i riley_albion == [0,112,204,316,386,498,610,702,814,884,996,1088]+--+-- > import Music.Theory.Tuning.Scala+-- > scl <- scl_load "riley_albion"+-- > cents_i (scale_tuning 0.01 scl) == cents_i riley_albion+riley_albion :: Tuning+riley_albion = Tuning (Left riley_albion_r) Nothing
+ Music/Theory/Tuning/Db/Werckmeister.hs view
@@ -0,0 +1,118 @@+-- | Andreas Werckmeister (1645-1706).+module Music.Theory.Tuning.Db.Werckmeister where++import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}++-- | Approximate ratios for 'werckmeister_iii'.+--+-- > let c = [0,90,192,294,390,498,588,696,792,888,996,1092]+-- > in map (round . ratio_to_cents) werckmeister_iii_ar == c+werckmeister_iii_ar :: [Approximate_Ratio]+werckmeister_iii_ar =+    let c0 = 2 ** (1/2)+        c1 = 2 ** (1/4)+        c2 = 8 ** (1/4)+    in [1,256/243+       ,64/81 * c0,32/27+       ,256/243 * c1+       ,4/3,1024/729+       ,8/9 * c2,128/81+       ,1024/729 * c1,16/9+       ,128/81 * c1]++-- | Cents for 'werckmeister_iii'.+werckmeister_iii_ar_c :: [Cents]+werckmeister_iii_ar_c = map approximate_ratio_to_cents werckmeister_iii_ar++-- | Werckmeister III, Andreas Werckmeister (1645-1706)+--+-- > cents_i werckmeister_iii == [0,90,192,294,390,498,588,696,792,888,996,1092]+--+-- > import Music.Theory.Tuning.Scala+-- > scl <- scl_load "werck3"+-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iii+werckmeister_iii :: Tuning+werckmeister_iii = Tuning (Right werckmeister_iii_ar_c) Nothing++-- | Approximate ratios for 'werckmeister_iv'.+--+-- > let c = [0,82,196,294,392,498,588,694,784,890,1004,1086]+-- > in map (round . ratio_to_cents) werckmeister_iv_ar == c+werckmeister_iv_ar :: [Approximate_Ratio]+werckmeister_iv_ar =+    let c0 = 2 ** (1/3)+        c1 = 4 ** (1/3)+    in [1,16384/19683 * c0+       ,8/9 * c0,32/27+       ,64/81 * c1+       ,4/3,1024/729+       ,32/27 * c0,8192/6561 * c0+       ,256/243 * c1,9/(4*c0)+       ,4096/2187]++-- | Cents for 'werckmeister_iv'.+werckmeister_iv_c :: [Cents]+werckmeister_iv_c = map approximate_ratio_to_cents werckmeister_iv_ar++-- | Werckmeister IV, Andreas Werckmeister (1645-1706)+--+-- > cents_i werckmeister_iv == [0,82,196,294,392,498,588,694,784,890,1004,1086]+--+-- > scl <- scl_load "werck4"+-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_iv+werckmeister_iv :: Tuning+werckmeister_iv = Tuning (Right werckmeister_iv_c) Nothing++-- | Approximate ratios for 'werckmeister_v'.+--+-- > let c = [0,96,204,300,396,504,600,702,792,900,1002,1098]+-- > in map (round . ratio_to_cents) werckmeister_v_ar == c+werckmeister_v_ar :: [Approximate_Ratio]+werckmeister_v_ar =+    let c0 = 2 ** (1/4)+        c1 = 2 ** (1/2)+        c2 = 8 ** (1/4)+    in [1,8/9 * c0+       ,9/8,c0+       ,8/9 * c1+       ,9/8 * c0,c1+       ,3/2,128/81+       ,c2,3/c2+       ,4/3 * c1]++-- | Cents for 'werckmeister_v'.+werckmeister_v_c :: [Cents]+werckmeister_v_c = map approximate_ratio_to_cents werckmeister_v_ar++-- | Werckmeister V, Andreas Werckmeister (1645-1706)+--+-- > cents_i werckmeister_v == [0,96,204,300,396,504,600,702,792,900,1002,1098]+--+-- > scl <- scl_load "werck5"+-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_v+werckmeister_v :: Tuning+werckmeister_v = Tuning (Right werckmeister_v_c) Nothing++-- | Ratios for 'werckmeister_vi', with supposed correction of 28/25 to 49/44.+--+-- > let c = [0,91,186,298,395,498,595,698,793,893,1000,1097]+-- > in map (round . ratio_to_cents) werckmeister_vi_r == c+werckmeister_vi_r :: [Rational]+werckmeister_vi_r =+    [1,98/93+    ,49/44 {- 28/25 -},196/165+    ,49/39+    ,4/3,196/139+    ,196/131,49/31+    ,196/117,98/55+    ,49/26]++-- | Werckmeister VI, Andreas Werckmeister (1645-1706)+--+-- > cents_i werckmeister_vi == [0,91,186,298,395,498,595,698,793,893,1000,1097]+--+-- > scl <- scl_load "werck6"+-- > cents_i (scale_tuning 0.01 scl) == cents_i werckmeister_vi+werckmeister_vi :: Tuning+werckmeister_vi = Tuning (Left werckmeister_vi_r) Nothing
− Music/Theory/Tuning/EFG.hs 
@@ -1,111 +0,0 @@--- | Euler-Fokker genus <http://www.huygens-fokker.org/microtonality/efg.html>-module Music.Theory.Tuning.EFG where--import Data.List {- base -}--import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Set.List as T {- hmt -}--import Music.Theory.Tuning {- hmt -}---- | Normal form, value with occurences count (ie. exponent in notation above).-type EFG i = [(i,Int)]---- | Degree of EFG, ie. sum of exponents.------ > efg_degree [(3,3),(7,2)] == 3 + 2-efg_degree :: EFG i -> Int-efg_degree = sum . map snd---- | Number of tones of EFG, ie. product of increment of exponents.------ > efg_tones [(3,3),(7,2)] == (3 + 1) * (2 + 1)-efg_tones :: EFG i -> Int-efg_tones = product . map ((+ 1) . snd)---- | Collate a genus given as a multiset into standard form, ie. histogram.------ > efg_collate [3,3,3,7,7] == [(3,3),(7,2)]-efg_collate :: Ord i => [i] -> EFG i-efg_collate = T.histogram . sort--{- | Factors of EFG given with co-ordinate of grid location.--> efg_factors [(3,3)]--> let r = [([0,0],[]),([0,1],[7]),([0,2],[7,7])->         ,([1,0],[3]),([1,1],[3,7]),([1,2],[3,7,7])->         ,([2,0],[3,3]),([2,1],[3,3,7]),([2,2],[3,3,7,7])->         ,([3,0],[3,3,3]),([3,1],[3,3,3,7]),([3,2],[3,3,3,7,7])]--> efg_factors [(3,3),(7,2)] == r---}-efg_factors :: EFG i -> [([Int],[i])]-efg_factors efg =-    let k = map (\(_,n) -> [0 .. n]) efg-        k' = if length efg == 1-             then concatMap (map return) k-             else T.nfold_cartesian_product k-        z = map fst efg-        f ix = (ix,concat (zipWith (\n m -> replicate n (z !! m)) ix [0..]))-    in map f k'--{- | Ratios of EFG, taking /n/ as the 1:1 ratio, with indices, folded into one octave.--> import Data.List-> let r = sort $ map snd $ efg_ratios 7 [(3,3),(7,2)]-> r == [1/1,9/8,8/7,9/7,21/16,189/128,3/2,27/16,12/7,7/4,27/14,63/32]-> map (round . ratio_to_cents) r == [0,204,231,435,471,675,702,906,933,969,1137,1173]--      0:         1/1          C          0.000 cents-      1:         9/8          D        203.910 cents-      2:         8/7          D+       231.174 cents-      3:         9/7          E+       435.084 cents-      4:        21/16         F-       470.781 cents-      5:       189/128        G-       674.691 cents-      6:         3/2          G        701.955 cents-      7:        27/16         A        905.865 cents-      8:        12/7          A+       933.129 cents-      9:         7/4          Bb-      968.826 cents-     10:        27/14         B+      1137.039 cents-     11:        63/32         C-      1172.736 cents-     12:         2/1          C       1200.000 cents--> let r' = sort $ map snd $ efg_ratios 5 [(5,2),(7,3)]-> r' == [1/1,343/320,35/32,49/40,5/4,343/256,7/5,49/32,8/5,1715/1024,7/4,245/128]-> map (round . ratio_to_cents) r' == [0,120,155,351,386,506,583,738,814,893,969,1124]--> let r'' = sort $ map snd $ efg_ratios 3 [(3,1),(5,1),(7,1)]-> r'' == [1/1,35/32,7/6,5/4,4/3,35/24,5/3,7/4]-> map (round . ratio_to_cents) r'' == [0,155,267,386,498,653,884,969]--> let c0 = [0,204,231,435,471,675,702,906,933,969,1137,1173,1200]-> let c1 = [0,120,155,351,386,506,583,738,814,893,969,1124,1200]-> let c2 = [0,155,267,386,498,653,884,969,1200]-> let f (c',y) = map (\x -> (x,y,x,y + 10)) c'-> map f (zip [c0,c1,c2] [0,20,40])---}-efg_ratios :: Real r => Rational -> EFG r -> [([Int],Rational)]-efg_ratios n =-    let to_r = fold_ratio_to_octave_err . (/ n) . toRational . product-        f (ix,i) = (ix,to_r i)-    in map f . efg_factors--{- | Generate a line drawing, as a set of (x0,y0,x1,y1) 4-tuples.-     h=row height, m=distance of vertical mark from row edge, k=distance between rows--> let e = [[3,3,3],[3,3,5],[3,5,5],[3,5,7],[3,7,7],[5,5,5],[5,5,7],[3,3,7],[5,7,7],[7,7,7]]-> let e = [[3,3,3],[5,5,5],[7,7,7],[3,3,5],[3,5,5],[5,5,7],[5,7,7],[3,7,7],[3,3,7],[3,5,7]]-> let e' = map efg_collate e-> efg_diagram_set (round,25,4,75) e'---}-efg_diagram_set :: (Enum n,Real n) => (Cents -> n,n,n,n) -> [EFG n] -> [(n,n,n,n)]-efg_diagram_set (to_f,h,m,k) e =-    let f = (++ [1200]) . sort . map (to_f . ratio_to_cents . snd) . efg_ratios 1-        g (c,y) = let y' = y + h-                      b = [(0,y,1200,y),(0,y',1200,y')]-                  in b ++ map (\x -> (x,y + m,x,y' - m)) c-    in concatMap g (zip (map f e) [0,k ..])
− Music/Theory/Tuning/ET.hs 
@@ -1,259 +0,0 @@--- | Equal temperament tuning tables.-module Music.Theory.Tuning.ET where--import Data.List {- base -}-import Data.List.Split {- split -}-import Data.Ratio {- base -}-import Text.Printf {- base -}--import qualified Music.Theory.List as T {- hmt -}-import Music.Theory.Pitch {- hmt -}-import Music.Theory.Pitch.Note {- hmt -}-import Music.Theory.Pitch.Spelling.Table {- hmt -}-import Music.Theory.Tuning {- hmt -}---- | 'octpc_to_pitch' and 'octpc_to_cps'.-octpc_to_pitch_cps_f0 :: (Floating n) => n -> OctPC -> (Pitch,n)-octpc_to_pitch_cps_f0 f0 x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps_f0 f0 x)---- | 'octpc_to_pitch' and 'octpc_to_cps'.-octpc_to_pitch_cps :: (Floating n) => OctPC -> (Pitch,n)-octpc_to_pitch_cps = octpc_to_pitch_cps_f0 440---- | 12-tone equal temperament table equating 'Pitch' and frequency--- over range of human hearing, where @A4@ has given frequency.------ > tbl_12et_f0 415-tbl_12et_f0 :: Double -> [(Pitch,Double)]-tbl_12et_f0 f0 =-    let z = [(o,pc) | o <- [0..10], pc <- [0..11]]-    in map (octpc_to_pitch_cps_f0 f0) z---- | 'tbl_12et_f0' @440@hz.------ > length tbl_12et == 132--- > minmax (map (round . snd) tbl_12et) == (16,31609)-tbl_12et :: [(Pitch,Double)]-tbl_12et = tbl_12et_f0 440---- | 24-tone equal temperament variant of 'tbl_12et_f0'.-tbl_24et_f0 :: Double -> [(Pitch,Double)]-tbl_24et_f0 f0 =-    let f x = let p = fmidi_to_pitch_err pc_spell_ks x-                  p' = pitch_rewrite_threequarter_alteration p-              in (p',fmidi_to_cps_f0 f0 x)-    in map f [12,12.5 .. 143.5]---- | 'tbl_24et_f0' @440@.------ > length tbl_24et == 264--- > T.minmax (map (round . snd) tbl_24et) == (16,32535)-tbl_24et :: [(Pitch,Double)]-tbl_24et = tbl_24et_f0 440---- | Given an @ET@ table (or like) find bounds of frequency.------ import qualified Music.Theory.Tuple as T------ > let r = Just (T.t2_map octpc_to_pitch_cps ((3,11),(4,0)))--- > in bounds_et_table tbl_12et 256 == r-bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s))-bounds_et_table = T.find_bounds True (compare . snd)---- | 'bounds_et_table' of 'tbl_12et'.------ > map bounds_12et_tone (hsn 17 55)-bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double))-bounds_12et_tone = bounds_et_table tbl_12et---- | Tuple indicating nearest 'Pitch' to /frequency/ with @ET@--- frequency, and deviation in hertz and 'Cents'.------ (cps,nearest-pitch,cps-of-nearest-pitch,cps-deviation,cents-deviation)-type HS_R p = (Double,p,Double,Double,Cents)---- | /n/-decimal places.------ > ndp 3 (1/3) == "0.333"-ndp :: Int -> Double -> String-ndp = printf "%.*f"---- | Pretty print 'HS_R'.-hs_r_pp :: (p -> String) -> Int -> HS_R p -> [String]-hs_r_pp pp n (f,p,pf,fd,c) =-    let dp = ndp n-    in [dp f-       ,pp p-       ,dp pf-       ,dp fd-       ,dp c]--hs_r_pitch_pp :: Int -> HS_R Pitch -> [String]-hs_r_pitch_pp = hs_r_pp pitch_pp--{- | Form 'HS_R' for /frequency/ by consulting table.--> let {f = 256->     ;f' = octpc_to_cps (4,0)->     ;r = (f,Pitch C Natural 4,f',f-f',fratio_to_cents (f/f'))}-> in nearest_et_table_tone tbl_12et 256 == r---}-nearest_et_table_tone :: [(p,Double)] -> Double -> HS_R p-nearest_et_table_tone tbl f =-    case bounds_et_table tbl f of-      Nothing -> error "nearest_et_table_tone: no bounds?"-      Just ((lp,lf),(rp,rf)) ->-          let ld = f - lf-              rd = f - rf-          in if abs ld < abs rd-             then (f,lp,lf,ld,fratio_to_cents (f/lf))-             else (f,rp,rf,rd,fratio_to_cents (f/rf))---- | 'nearest_et_table_tone' for 'tbl_12et'.-nearest_12et_tone :: Double -> HS_R Pitch-nearest_12et_tone = nearest_et_table_tone tbl_12et---- | 'nearest_et_table_tone' for 'tbl_24et'.------ > let r = "55.0 A1 55.0 0.0 0.0"--- > in unwords (hs_r_pitch_pp 1 (nearest_24et_tone 55)) == r-nearest_24et_tone :: Double -> HS_R Pitch-nearest_24et_tone = nearest_et_table_tone tbl_24et---- * 72ET---- | Monzo 72-edo HEWM notation.  The domain is (-9,9).--- <http://www.tonalsoft.com/enc/number/72edo.aspx>------ > let r = ["+",">","^","#<","#-","#","#+","#>","#^"]--- > in map alteration_72et_monzo [1 .. 9] == r------ > let r = ["-","<","v","b>","b+","b","b-","b<","bv"]--- > in map alteration_72et_monzo [-1,-2 .. -9] == r-alteration_72et_monzo :: Integral n => n -> String-alteration_72et_monzo n =-    let spl = splitOn ","-        asc = spl ",+,>,^,#<,#-,#,#+,#>,#^"-        dsc = spl ",-,<,v,b>,b+,b,b-,b<,bv"-    in case compare n 0 of-         LT -> genericIndex dsc (- n)-         EQ -> ""-         GT -> genericIndex asc n---- | Given a midi note number and @1/6@ deviation determine 'Pitch''--- and frequency.------ > let {f = pitch'_pp . fst . pitch_72et--- >     ;r = "C4 C+4 C>4 C^4 C#<4 C#-4 C#4 C#+4 C#>4 C#^4"}--- > in unwords (map f (zip (repeat 60) [0..9])) == r------ > let {f = pitch'_pp . fst . pitch_72et--- >     ;r = "A4 A+4 A>4 A^4 Bb<4 Bb-4 Bb4 Bb+4 Bb>4 Bv4"}--- > in unwords (map f (zip (repeat 69) [0..9]))------ > let {f = pitch'_pp . fst . pitch_72et--- >     ;r = "Bb4 Bb+4 Bb>4 Bv4 B<4 B-4 B4 B+4 B>4 B^4"}--- > in unwords (map f (zip (repeat 70) [0..9])) == r-pitch_72et :: (Midi,Int) -> (Pitch_R,Double)-pitch_72et (x,n) =-    let p = midi_to_pitch_ks x-        t = note p-        a = alteration p-        (t',n') = case a of-                    Flat -> if n < (-3) then (pred t,n + 6) else (t,n - 6)-                    Natural -> (t,n)-                    Sharp -> if n > 3 then (succ t,n - 6) else (t,n + 6)-                    _ -> error "pitch_72et: alteration?"-        a' = alteration_72et_monzo n'-        x' = fromIntegral x + (fromIntegral n / 6)-        r = (Pitch_R t' (fromIntegral n' % 12,a') (octave p),fmidi_to_cps x')-        r' = if n > 3-             then pitch_72et (x + 1,n - 6)-             else if n < (-3)-                  then pitch_72et (x - 1,n + 6)-                  else r-    in case a of-         Natural -> r'-         _ -> r---- | 72-tone equal temperament table equating 'Pitch'' and frequency--- over range of human hearing, where @A4@ = @440@hz.------ > length tbl_72et == 792--- > min_max (map (round . snd) tbl_72et) == (16,33167)-tbl_72et :: [(Pitch_R,Double)]-tbl_72et =-    let f n = map pitch_72et (zip (replicate 6 n) [0..5])-    in concatMap f [12 .. 143]---- | 'nearest_et_table_tone' for 'tbl_72et'.------ > let r = "324.0 E<4 323.3 0.7 3.5"--- > in unwords (hs_r_pp pitch'_pp 1 (nearest_72et_tone 324))------ > let {f = take 2 . hs_r_pp pitch'_pp 1 . nearest_72et_tone . snd}--- > in mapM_ (print . unwords . f) tbl_72et-nearest_72et_tone :: Double -> HS_R Pitch_R-nearest_72et_tone = nearest_et_table_tone tbl_72et---- * Detune---- | 'Pitch' with 12-ET/24-ET tuning deviation given in 'Cents'.-type Pitch_Detune = (Pitch,Cents)---- | Extract 'Pitch_Detune' from 'HS_R'.-hsr_to_pitch_detune :: HS_R Pitch -> Pitch_Detune-hsr_to_pitch_detune (_,p,_,_,c) = (p,c)---- | Nearest 12-ET 'Pitch_Detune' to indicated frequency (hz).------ > nearest_pitch_detune_12et 452.8929841231365-nearest_pitch_detune_12et :: Double -> Pitch_Detune-nearest_pitch_detune_12et = hsr_to_pitch_detune . nearest_12et_tone---- | Nearest 24-ET 'Pitch_Detune' to indicated frequency (hz).------ > nearest_pitch_detune_24et 452.8929841231365-nearest_pitch_detune_24et :: Double -> Pitch_Detune-nearest_pitch_detune_24et = hsr_to_pitch_detune . nearest_24et_tone---- | Given /near/ function, /f0/ and ratio derive 'Pitch_Detune'.-ratio_to_pitch_detune :: (Double -> HS_R Pitch) -> OctPC -> Rational -> Pitch_Detune-ratio_to_pitch_detune near_f f0 r =-    let f = octpc_to_cps f0 * realToFrac r-        (_,p,_,_,c) = near_f f-    in (p,c)---- | Frequency (hz) of 'Pitch_Detune'.------ > pitch_detune_to_cps (octpc_to_pitch pc_spell_ks (4,9),50)-pitch_detune_to_cps :: Floating n => Pitch_Detune -> n-pitch_detune_to_cps (p,d) = cps_shift_cents (pitch_to_cps p) (realToFrac d)---- | 'ratio_to_pitch_detune' of 'nearest_12et_tone'-ratio_to_pitch_detune_12et :: OctPC -> Rational -> Pitch_Detune-ratio_to_pitch_detune_12et = ratio_to_pitch_detune nearest_12et_tone---- | 'ratio_to_pitch_detune' of 'nearest_24et_tone'-ratio_to_pitch_detune_24et :: OctPC -> Rational -> Pitch_Detune-ratio_to_pitch_detune_24et = ratio_to_pitch_detune nearest_24et_tone--pitch_detune_in_octave_nearest  :: Pitch -> Pitch_Detune -> Pitch_Detune-pitch_detune_in_octave_nearest p1 (p2,d2) = (pitch_in_octave_nearest p1 p2,d2)---- | Markdown pretty-printer for 'Pitch_Detune'.-pitch_detune_md :: Pitch_Detune -> String-pitch_detune_md (p,c) = pitch_pp p ++ cents_diff_md (round c :: Integer)---- | HTML pretty-printer for 'Pitch_Detune'.-pitch_detune_html :: Pitch_Detune -> String-pitch_detune_html (p,c) = pitch_pp p ++ cents_diff_html (round c :: Integer)---- | No-octave variant of 'pitch_detune_md'.-pitch_class_detune_md :: Pitch_Detune -> String-pitch_class_detune_md (p,c) = pitch_class_pp p ++ cents_diff_md (round c :: Integer)---- | No-octave variant of 'pitch_detune_html'.-pitch_class_detune_html :: Pitch_Detune -> String-pitch_class_detune_html (p,c) = pitch_class_pp p ++ cents_diff_html (round c :: Integer)
+ Music/Theory/Tuning/Efg.hs view
@@ -0,0 +1,111 @@+-- | Euler-Fokker genus <http://www.huygens-fokker.org/microtonality/efg.html>+module Music.Theory.Tuning.Efg where++import Data.List {- base -}++import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Set.List as T {- hmt -}++import Music.Theory.Tuning {- hmt -}++-- | Normal form, value with occurences count (ie. exponent in notation above).+type Efg i = [(i,Int)]++-- | Degree of Efg, ie. sum of exponents.+--+-- > efg_degree [(3,3),(7,2)] == 3 + 2+efg_degree :: Efg i -> Int+efg_degree = sum . map snd++-- | Number of tones of Efg, ie. product of increment of exponents.+--+-- > efg_tones [(3,3),(7,2)] == (3 + 1) * (2 + 1)+efg_tones :: Efg i -> Int+efg_tones = product . map ((+ 1) . snd)++-- | Collate a genus given as a multiset into standard form, ie. histogram.+--+-- > efg_collate [3,3,3,7,7] == [(3,3),(7,2)]+efg_collate :: Ord i => [i] -> Efg i+efg_collate = T.histogram . sort++{- | Factors of Efg given with co-ordinate of grid location.++> efg_factors [(3,3)]++> let r = [([0,0],[]),([0,1],[7]),([0,2],[7,7])+>         ,([1,0],[3]),([1,1],[3,7]),([1,2],[3,7,7])+>         ,([2,0],[3,3]),([2,1],[3,3,7]),([2,2],[3,3,7,7])+>         ,([3,0],[3,3,3]),([3,1],[3,3,3,7]),([3,2],[3,3,3,7,7])]++> efg_factors [(3,3),(7,2)] == r++-}+efg_factors :: Efg i -> [([Int],[i])]+efg_factors efg =+    let k = map (\(_,n) -> [0 .. n]) efg+        k' = if length efg == 1+             then concatMap (map return) k+             else T.nfold_cartesian_product k+        z = map fst efg+        f ix = (ix,concat (zipWith (\n m -> replicate n (z !! m)) ix [0..]))+    in map f k'++{- | Ratios of Efg, taking /n/ as the 1:1 ratio, with indices, folded into one octave.++> import Data.List+> let r = sort $ map snd $ efg_ratios 7 [(3,3),(7,2)]+> r == [1/1,9/8,8/7,9/7,21/16,189/128,3/2,27/16,12/7,7/4,27/14,63/32]+> map (round . ratio_to_cents) r == [0,204,231,435,471,675,702,906,933,969,1137,1173]++      0:         1/1          C          0.000 cents+      1:         9/8          D        203.910 cents+      2:         8/7          D+       231.174 cents+      3:         9/7          E+       435.084 cents+      4:        21/16         F-       470.781 cents+      5:       189/128        G-       674.691 cents+      6:         3/2          G        701.955 cents+      7:        27/16         A        905.865 cents+      8:        12/7          A+       933.129 cents+      9:         7/4          Bb-      968.826 cents+     10:        27/14         B+      1137.039 cents+     11:        63/32         C-      1172.736 cents+     12:         2/1          C       1200.000 cents++> let r' = sort $ map snd $ efg_ratios 5 [(5,2),(7,3)]+> r' == [1/1,343/320,35/32,49/40,5/4,343/256,7/5,49/32,8/5,1715/1024,7/4,245/128]+> map (round . ratio_to_cents) r' == [0,120,155,351,386,506,583,738,814,893,969,1124]++> let r'' = sort $ map snd $ efg_ratios 3 [(3,1),(5,1),(7,1)]+> r'' == [1/1,35/32,7/6,5/4,4/3,35/24,5/3,7/4]+> map (round . ratio_to_cents) r'' == [0,155,267,386,498,653,884,969]++> let c0 = [0,204,231,435,471,675,702,906,933,969,1137,1173,1200]+> let c1 = [0,120,155,351,386,506,583,738,814,893,969,1124,1200]+> let c2 = [0,155,267,386,498,653,884,969,1200]+> let f (c',y) = map (\x -> (x,y,x,y + 10)) c'+> map f (zip [c0,c1,c2] [0,20,40])++-}+efg_ratios :: Real r => Rational -> Efg r -> [([Int],Rational)]+efg_ratios n =+    let to_r = fold_ratio_to_octave_err . (/ n) . toRational . product+        f (ix,i) = (ix,to_r i)+    in map f . efg_factors++{- | Generate a line drawing, as a set of (x0,y0,x1,y1) 4-tuples.+     h=row height, m=distance of vertical mark from row edge, k=distance between rows++> let e = [[3,3,3],[3,3,5],[3,5,5],[3,5,7],[3,7,7],[5,5,5],[5,5,7],[3,3,7],[5,7,7],[7,7,7]]+> let e = [[3,3,3],[5,5,5],[7,7,7],[3,3,5],[3,5,5],[5,5,7],[5,7,7],[3,7,7],[3,3,7],[3,5,7]]+> let e' = map efg_collate e+> efg_diagram_set (round,25,4,75) e'++-}+efg_diagram_set :: (Enum n,Real n) => (Cents -> n,n,n,n) -> [Efg n] -> [(n,n,n,n)]+efg_diagram_set (to_f,h,m,k) e =+    let f = (++ [1200]) . sort . map (to_f . ratio_to_cents . snd) . efg_ratios 1+        g (c,y) = let y' = y + h+                      b = [(0,y,1200,y),(0,y',1200,y')]+                  in b ++ map (\x -> (x,y + m,x,y' - m)) c+    in concatMap g (zip (map f e) [0,k ..])
+ Music/Theory/Tuning/Et.hs view
@@ -0,0 +1,253 @@+-- | Equal temperament tuning tables.+module Music.Theory.Tuning.Et where++import Data.List {- base -}+import Data.List.Split {- split -}+import Data.Ratio {- base -}+import Text.Printf {- base -}++import qualified Music.Theory.List as T {- hmt -}+import Music.Theory.Pitch {- hmt -}+import Music.Theory.Pitch.Note {- hmt -}+import Music.Theory.Pitch.Spelling.Table {- hmt -}+import Music.Theory.Tuning {- hmt -}++-- | 'octpc_to_pitch' and 'octpc_to_cps_k0'.+octpc_to_pitch_cps_k0 :: (Floating n) => (n,n) -> OctPc -> (Pitch,n)+octpc_to_pitch_cps_k0 zero x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps_k0 zero x)++-- | 'octpc_to_pitch_cps_k0' of (69,440)+octpc_to_pitch_cps :: (Floating n) => OctPc -> (Pitch,n)+octpc_to_pitch_cps = octpc_to_pitch_cps_k0 (69,440)++-- | 12-tone equal temperament table equating 'Pitch' and frequency+-- over range of human hearing, where @A4@ has given frequency.+--+-- > tbl_12et_k0 (69,440)+tbl_12et_k0 :: (Double,Double) -> [(Pitch,Double)]+tbl_12et_k0 zero =+    let z = [(o,pc) | o <- [-5 .. 10], pc <- [0 .. 11]]+    in map (octpc_to_pitch_cps_k0 zero) z++-- | 'tbl_12et_k0' @(69,440)@.+--+-- > length tbl_12et == 192+-- > T.minmax (map (round . snd) tbl_12et) == (1,31609)+tbl_12et :: [(Pitch,Double)]+tbl_12et = tbl_12et_k0 (69,440)++-- | 24-tone equal temperament variant of 'tbl_12et_k0'.+tbl_24et_k0 :: (Double,Double) -> [(Pitch,Double)]+tbl_24et_k0 zero =+    let f x = let p = fmidi_to_pitch_err pc_spell_ks x+                  p' = pitch_rewrite_threequarter_alteration p+              in (p',fmidi_to_cps_k0 zero x)+        k0 = -36+    in map f [k0,k0 + 0.5 .. 143.5]++-- | 'tbl_24et_k0' @(69,440)@.+--+-- > length tbl_24et == 360+-- > T.minmax (map (round . snd) tbl_24et) == (1,32535)+tbl_24et :: [(Pitch,Double)]+tbl_24et = tbl_24et_k0 (69,440)++-- | Given an @Et@ table (or like) find bounds of frequency.+--+-- > import qualified Music.Theory.Tuple as T+-- > let r = Just (T.t2_map octpc_to_pitch_cps ((3,11),(4,0)))+-- > bounds_et_table tbl_12et 256 == r+bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s))+bounds_et_table = T.find_bounds True (compare . snd)++-- | 'bounds_et_table' of 'tbl_12et'.+--+-- > import qualified Music.Theory.Tuning.Hs as T+-- > map bounds_12et_tone (T.harmonic_series_cps_n 17 55)+bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double))+bounds_12et_tone = bounds_et_table tbl_12et++-- | Tuple indicating nearest 'Pitch' to /frequency/ with @Et@+-- frequency, and deviation in hertz and 'Cents'.+--+-- (cps,nearest-pitch,cps-of-nearest-pitch,cps-deviation,cents-deviation)+type HS_R p = (Double,p,Double,Double,Cents)++-- | /n/-decimal places.+--+-- > ndp 3 (1/3) == "0.333"+ndp :: Int -> Double -> String+ndp = printf "%.*f"++-- | Pretty print 'HS_R'.  This discards the /cps-deviation/ field, ie. it has only four fields.+hs_r_pp :: (p -> String) -> Int -> HS_R p -> [String]+hs_r_pp pp n (f,p,pf,_,c) = let dp = ndp n in [dp f,pp p,dp pf,dp c]++-- | 'hs_r_pp' of 'pitch_pp'+hs_r_pitch_pp :: Int -> HS_R Pitch -> [String]+hs_r_pitch_pp = hs_r_pp pitch_pp++{- | Form 'HS_R' for /frequency/ by consulting table.++> let f = 256+> let f' = octpc_to_cps (4,0)+> let r = (f,Pitch C Natural 4,f',f-f',fratio_to_cents (f/f'))+> nearest_et_table_tone tbl_12et 256 == r++-}+nearest_et_table_tone :: [(p,Double)] -> Double -> HS_R p+nearest_et_table_tone tbl f =+    case bounds_et_table tbl f of+      Nothing -> error "nearest_et_table_tone: no bounds?"+      Just ((lp,lf),(rp,rf)) ->+          let ld = f - lf+              rd = f - rf+          in if abs ld < abs rd+             then (f,lp,lf,ld,fratio_to_cents (f/lf))+             else (f,rp,rf,rd,fratio_to_cents (f/rf))++-- | 'nearest_et_table_tone' for 'tbl_12et_k0'.+nearest_12et_tone_k0 :: (Double,Double) -> Double -> HS_R Pitch+nearest_12et_tone_k0 zero = nearest_et_table_tone (tbl_12et_k0 zero)++-- | 'nearest_et_table_tone' for 'tbl_24et'.+--+-- > let r = "55.0 A1 55.0 0.0"+-- > unwords (hs_r_pitch_pp 1 (nearest_24et_tone_k0 (69,440) 55)) == r+nearest_24et_tone_k0 :: (Double,Double) -> Double -> HS_R Pitch+nearest_24et_tone_k0 zero = nearest_et_table_tone (tbl_24et_k0 zero)++-- * 72Et++-- | Monzo 72-edo HEWM notation.  The domain is (-9,9).+-- <http://www.tonalsoft.com/enc/number/72edo.aspx>+--+-- > let r = ["+",">","^","#<","#-","#","#+","#>","#^"]+-- > map alteration_72et_monzo [1 .. 9] == r+--+-- > let r = ["-","<","v","b>","b+","b","b-","b<","bv"]+-- > map alteration_72et_monzo [-1,-2 .. -9] == r+alteration_72et_monzo :: Integral n => n -> String+alteration_72et_monzo n =+    let spl = splitOn ","+        asc = spl ",+,>,^,#<,#-,#,#+,#>,#^"+        dsc = spl ",-,<,v,b>,b+,b,b-,b<,bv"+    in case compare n 0 of+         LT -> genericIndex dsc (- n)+         EQ -> ""+         GT -> genericIndex asc n++-- | Given a midi note number and @1/6@ deviation determine 'Pitch''+-- and frequency.+--+-- > let f = pitch_r_pp . fst . pitch_72et_k0 (69,440)+-- > let r = "C4 C+4 C>4 C^4 C#<4 C#-4 C#4 C#+4 C#>4 C#^4"+-- > unwords (map f (zip (repeat 60) [0..9])) == r+--+-- > let r = "A4 A+4 A>4 A^4 Bb<4 Bb-4 Bb4 Bb+4 Bb>4 Bv4"+-- > unwords (map f (zip (repeat 69) [0..9])) == r+--+-- > let r = "Bb4 Bb+4 Bb>4 Bv4 B<4 B-4 B4 B+4 B>4 B^4"+-- > unwords (map f (zip (repeat 70) [0..9])) == r+pitch_72et_k0 :: (Double,Double) -> (Midi,Int) -> (Pitch_R,Double)+pitch_72et_k0 zero (x,n) =+    let p = midi_to_pitch_ks x+        t = note p+        a = alteration p+        (t',n') = case a of+                    Flat -> if n < (-3) then (pred t,n + 6) else (t,n - 6)+                    Natural -> (t,n)+                    Sharp -> if n > 3 then (succ t,n - 6) else (t,n + 6)+                    _ -> error "pitch_72et: alteration?"+        a' = alteration_72et_monzo n'+        x' = fromIntegral x + (fromIntegral n / 6)+        r = (Pitch_R t' (fromIntegral n' % 12,a') (octave p),fmidi_to_cps_k0 zero x')+        r' = if n > 3+             then pitch_72et_k0 zero (x + 1,n - 6)+             else if n < (-3)+                  then pitch_72et_k0 zero (x - 1,n + 6)+                  else r+    in case a of+         Natural -> r'+         _ -> r++-- | 72-tone equal temperament table equating 'Pitch'' and frequency+-- over range of human hearing, where @A4@ = @440@hz.+--+-- > length (tbl_72et_k0 (69,440)) == 792+-- > T.minmax (map (round . snd) (tbl_72et_k0 (69,440))) == (16,33167)+tbl_72et_k0 :: (Double, Double) -> [(Pitch_R,Double)]+tbl_72et_k0 zero =+    let f n = zipWith (curry (pitch_72et_k0 zero)) (replicate 6 n) [0..5]+    in concatMap f [12 .. 143]++-- | 'nearest_et_table_tone' for 'tbl_72et'.+--+-- > let r = "324.0 E<4 323.3 0.7 3.5"+-- > unwords (hs_r_pp pitch_r_pp 1 (nearest_72et_tone_k0 (69,440) 324))+--+-- > let f = take 2 . hs_r_pp pitch_r_pp 1 . nearest_72et_tone_k0 (69,440) . snd+-- > mapM_ (print . unwords . f) (tbl_72et_k0 (69,440))+nearest_72et_tone_k0 :: (Double,Double) -> Double -> HS_R Pitch_R+nearest_72et_tone_k0 zero = nearest_et_table_tone (tbl_72et_k0 zero)++-- * Detune++-- | 'Pitch' with 12-Et/24-Et tuning deviation given in 'Cents'.+type Pitch_Detune = (Pitch,Cents)++-- | Extract 'Pitch_Detune' from 'HS_R'.+hsr_to_pitch_detune :: HS_R Pitch -> Pitch_Detune+hsr_to_pitch_detune (_,p,_,_,c) = (p,c)++-- | Nearest 12-Et 'Pitch_Detune' to indicated frequency (hz).+--+-- > nearest_pitch_detune_12et_k0 (69,440) 452.8929841231365+nearest_pitch_detune_12et_k0 :: (Double, Double) -> Double -> Pitch_Detune+nearest_pitch_detune_12et_k0 zero = hsr_to_pitch_detune . nearest_12et_tone_k0 zero++-- | Nearest 24-Et 'Pitch_Detune' to indicated frequency (hz).+--+-- > nearest_pitch_detune_24et_k0 (69,440) 452.8929841231365+nearest_pitch_detune_24et_k0 :: (Double, Double) -> Double -> Pitch_Detune+nearest_pitch_detune_24et_k0 zero = hsr_to_pitch_detune . nearest_24et_tone_k0 zero++-- | Given /near/ function, /f0/ and ratio derive 'Pitch_Detune'.+ratio_to_pitch_detune :: (Double -> HS_R Pitch) -> OctPc -> Rational -> Pitch_Detune+ratio_to_pitch_detune near_f f0 r =+    let f = octpc_to_cps f0 * realToFrac r+        (_,p,_,_,c) = near_f f+    in (p,c)++-- | Frequency (hz) of 'Pitch_Detune'.+--+-- > pitch_detune_to_cps (octpc_to_pitch pc_spell_ks (4,9),50)+pitch_detune_to_cps :: Floating n => Pitch_Detune -> n+pitch_detune_to_cps (p,d) = cps_shift_cents (pitch_to_cps p) (realToFrac d)++-- | 'ratio_to_pitch_detune' of 'nearest_12et_tone'+ratio_to_pitch_detune_12et_k0 :: (Double, Double) -> OctPc -> Rational -> Pitch_Detune+ratio_to_pitch_detune_12et_k0 zero = ratio_to_pitch_detune (nearest_12et_tone_k0 zero)++-- | 'ratio_to_pitch_detune' of 'nearest_24et_tone'+ratio_to_pitch_detune_24et_k0 :: (Double, Double) -> OctPc -> Rational -> Pitch_Detune+ratio_to_pitch_detune_24et_k0 zero = ratio_to_pitch_detune (nearest_24et_tone_k0 zero)++pitch_detune_in_octave_nearest  :: Pitch -> Pitch_Detune -> Pitch_Detune+pitch_detune_in_octave_nearest p1 (p2,d2) = (pitch_in_octave_nearest p1 p2,d2)++-- | Markdown pretty-printer for 'Pitch_Detune'.+pitch_detune_md :: Pitch_Detune -> String+pitch_detune_md (p,c) = pitch_pp p ++ cents_diff_md (round c :: Integer)++-- | HTML pretty-printer for 'Pitch_Detune'.+pitch_detune_html :: Pitch_Detune -> String+pitch_detune_html (p,c) = pitch_pp p ++ cents_diff_html (round c :: Integer)++-- | No-octave variant of 'pitch_detune_md'.+pitch_class_detune_md :: Pitch_Detune -> String+pitch_class_detune_md (p,c) = pitch_class_pp p ++ cents_diff_md (round c :: Integer)++-- | No-octave variant of 'pitch_detune_html'.+pitch_class_detune_html :: Pitch_Detune -> String+pitch_class_detune_html (p,c) = pitch_class_pp p ++ cents_diff_html (round c :: Integer)
Music/Theory/Tuning/Gann_1993.hs view
@@ -84,7 +84,7 @@  -} lmy_wtp_uniq :: [(Rational,[(T.PitchClass,T.PitchClass)])]-lmy_wtp_uniq = sortOn (T.ratio_nd_sum . fst) $ T.collate_on fst snd $ lmy_wtp_univ+lmy_wtp_uniq = sortOn (T.ratio_nd_sum . fst) (T.collate_on fst snd lmy_wtp_univ)  {- | Gann, 1993, p.137. @@ -136,6 +136,6 @@ lmy_wtp_euler =     let {l1 = T.tun_seq 4 (3/2) (49/32)         ;l2 = T.tun_seq 5 (3/2) (7/4)-        ;l3 = T.tun_seq 3 (3/2) (1/1)+        ;l3 = T.tun_seq 3 (3/2) 1         ;(c1,c2) = T.euler_align_rat (7/4,7/4) (l1,l2,l3)}     in ([l1,l2,l3],c1 ++ c2)
− Music/Theory/Tuning/Graph/ISET.hs 
@@ -1,126 +0,0 @@--- | Tuning graph with edges determined by interval set.-module Music.Theory.Tuning.Graph.ISET where--import Data.List {- base -}-import Data.Maybe {- base -}--import qualified Data.Graph.Inductive.Graph as FGL {- fgl -}-import qualified Data.Graph.Inductive.PatriciaTree as FGL {- fgl -}--import qualified Music.Theory.Graph.Dot as T {- hmt -}-import qualified Music.Theory.Graph.FGL as T {- hmt -}-import qualified Music.Theory.Graph.Type as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Show as T {- hmt -}-import qualified Music.Theory.Tuning as T {- hmt -}-import qualified Music.Theory.Tuning.Graph.Euler as Euler {- hmt -}-import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}---- * R---- | R = Rational-type R = Rational---- | Flip a ratio in (1,2) and multiply by 2.------ > import Data.Ratio {- base -}--- > map r_flip [5%4,3%2,7%4] == [8%5,4%3,8%7]--- > map r_flip [3/2,5/4,7/4] == [4/3,8/5,8/7]-r_flip :: R -> R-r_flip n = if n < 1 || n > 2 then error "r_flip" else 1 / n * 2---- | r = ratio, nrm = normalise-r_nrm :: R -> R-r_nrm = T.ratio_interval_class_by id---- | The folded interval from p to q.------ > r_rel (1,3/2) == 4/3-r_rel :: (R,R) -> R-r_rel (p,q) = T.fold_ratio_to_octave_err (p / q)---- | The interval set /i/ and it's 'r_flip'.-iset_sym :: [R] -> [R]-iset_sym l = l ++ map r_flip l---- | Require r to have a perfect octave as last element, and remove it.-rem_oct :: [R] -> [R]-rem_oct r = if last r /= 2 then error "rem_oct" else T.drop_last r--r_pcset :: [R] -> [Int]-r_pcset = sort . map (T.ratio_to_pc 0)--r_pcset_univ :: [R] -> [Int]-r_pcset_univ = nub . r_pcset---- | Does [R] construct indicated /pcset/.-r_is_pcset :: [Int] -> [R] -> Bool-r_is_pcset pcset = ((==) pcset) . r_pcset---- * G---- | Edges are (v1,v2) where v1 < v2-type G = T.GR R--edj_r :: (R, R) -> R-edj_r = r_nrm . r_rel---- | The graph with vertices /scl_r/ and all edges where the interval (i,j) is in /iset/.-mk_graph :: [R] -> [R] -> G-mk_graph iset scl_r =-  (scl_r-  ,filter-    (\e -> edj_r e `elem` iset_sym iset)-    [(p,q) |-     p <- scl_r,-     q <- scl_r,-     p < q])--gen_graph :: Ord v => [T.DOT_META_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]-gen_graph opt pp es = T.fgl_to_udot opt pp (T.g_from_edges_l es)--g_to_dot :: Int -> [(String,String)] -> (R -> [(String,String)]) -> G -> [String]-g_to_dot k attr v_attr (_,e_set) =-  let opt =-        [("graph:layout","neato")-        ,("node:shape","plaintext")-        ,("node:fontsize","10")-        ,("node:fontname","century schoolbook")-        ,("edge:fontsize","9")]-  in gen_graph-     (opt ++ attr)-     (\(_,v) -> ("label",Euler.rat_label (k,True) v) : v_attr v-     ,\(_,e) -> [("label",T.rational_pp e)])-     (map (\e -> (e,edj_r e)) e_set)---- * SCALA--mk_graph_scl :: [R] -> Scala.Scale -> G-mk_graph_scl iset = mk_graph iset . rem_oct . Scala.scale_ratios_req--scl_to_dot :: ([R], Int, [(String, String)], R -> [(String, String)]) -> String -> IO [String]-scl_to_dot (iset,k,attr,v_attr) nm = do-  sc <- Scala.scl_load nm-  let gr = mk_graph_scl iset sc-  return (g_to_dot k attr v_attr gr)---- * FGL--graph_to_fgl :: G -> FGL.Gr R R-graph_to_fgl (v,e) =-  let fgl_v = zip [0..] v-      r_to_v :: R -> Int-      r_to_v x = fromJust (T.reverse_lookup x fgl_v)-      fgl_e = map (\(p,q) -> (r_to_v p,r_to_v q,edj_r (p,q))) e-  in FGL.mkGraph fgl_v fgl_e--mk_graph_fgl :: [R] -> [R] -> FGL.Gr R R-mk_graph_fgl iset = graph_to_fgl . mk_graph iset--{---- | List of nodes at /g/ connected to node /r/.-g_edge_list :: G -> R -> [R]-g_edge_list (_,e) r =-  let f (p,q) = if r == p then Just q else if r == q then Just p else Nothing-  in mapMaybe f e--}
+ Music/Theory/Tuning/Graph/Iset.hs view
@@ -0,0 +1,127 @@+-- | 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.Type as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Show as T {- hmt-base -}++import qualified Music.Theory.Graph.Dot as T {- hmt -}+import qualified Music.Theory.Graph.Fgl 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.Graph_Pp v e -> [T.Edge_Lbl v e] -> [String]+gen_graph opt pp es = T.fgl_to_udot opt pp (T.g_from_edges_l es)++g_to_dot :: Int -> [(String,String)] -> (R -> [(String,String)]) -> G -> [String]+g_to_dot k attr v_attr (_,e_set) =+  let opt =+        [("graph:layout","neato")+        ,("node:shape","plaintext")+        ,("node:fontsize","10")+        ,("node:fontname","century schoolbook")+        ,("edge:fontsize","9")]+  in gen_graph+     (opt ++ attr)+     (\(_,v) -> ("label",Euler.rat_label (k,True) v) : v_attr v+     ,\(_,e) -> [("label",T.rational_pp e)])+     (map (\e -> (e,edj_r e)) e_set)++-- * SCALA++mk_graph_scl :: [R] -> Scala.Scale -> G+mk_graph_scl iset = mk_graph iset . rem_oct . Scala.scale_ratios_req++scl_to_dot :: ([R], Int, [(String, String)], R -> [(String, String)]) -> String -> IO [String]+scl_to_dot (iset,k,attr,v_attr) nm = do+  sc <- Scala.scl_load nm+  let gr = mk_graph_scl iset sc+  return (g_to_dot k attr v_attr gr)++-- * Fgl++graph_to_fgl :: G -> Fgl.Gr R R+graph_to_fgl (v,e) =+  let fgl_v = zip [0..] v+      r_to_v :: R -> Int+      r_to_v x = fromJust (T.reverse_lookup x fgl_v)+      fgl_e = map (\(p,q) -> (r_to_v p,r_to_v q,edj_r (p,q))) e+  in Fgl.mkGraph fgl_v fgl_e++mk_graph_fgl :: [R] -> [R] -> Fgl.Gr R R+mk_graph_fgl iset = graph_to_fgl . mk_graph iset++{-+-- | List of nodes at /g/ connected to node /r/.+g_edge_list :: G -> R -> [R]+g_edge_list (_,e) r =+  let f (p,q) = if r == p then Just q else if r == q then Just p else Nothing+  in mapMaybe f e+-}
− Music/Theory/Tuning/HS.hs 
@@ -1,81 +0,0 @@--- | Harmonic series-module Music.Theory.Tuning.HS where--import Data.List {- base -}-import Data.Ratio {- base -}-import qualified Safe {- safe -}--import qualified Music.Theory.Pitch as T {- hmt -}-import Music.Theory.Tuning {- hmt -}-import Music.Theory.Tuning.Type {- hmt -}----- | Harmonic series to /n/th partial, with indicated octave.------ > harmonic_series 17 2-harmonic_series :: Integer -> Maybe Rational -> Tuning-harmonic_series n o = Tuning (Left [1 .. n%1]) (fmap Left o)---- | Harmonic series on /n/.-harmonic_series_cps :: (Num t, Enum t) => t -> [t]-harmonic_series_cps n = [n,n * 2 ..]---- | /n/ elements of 'harmonic_series_cps'.------ > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935]--- > harmonic_series_cps_n 17 55 == r-harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a]-harmonic_series_cps_n n = take n . harmonic_series_cps---- | Sub-harmonic series on /n/.-subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t]-subharmonic_series_cps n = map (* n) (map recip [1..])---- | /n/ elements of 'harmonic_series_cps'.------ > let r = [1760,880,587,440,352,293,251,220,196,176,160,147,135,126,117,110,104]--- > map round (subharmonic_series_cps_n 17 1760) == r-subharmonic_series_cps_n :: (Fractional t,Enum t) => Int -> t -> [t]-subharmonic_series_cps_n n = take n . subharmonic_series_cps---- | /n/th partial of /f1/, ie. one indexed.------ > map (partial 55) [1,5,3] == [55,275,165]-partial :: (Num a, Enum a) => a -> Int -> a-partial f1 k = harmonic_series_cps f1 `Safe.at` (k - 1)---- | Derivative harmonic series, based on /k/th partial of /f1/.------ > import Music.Theory.Pitch------ > let r = [52,103,155,206,258,309,361,412,464,515,567,618,670,721,773]--- > let d = harmonic_series_cps_derived 5 (T.octpc_to_cps (1,4))--- > map round (take 15 d) == r-harmonic_series_cps_derived :: (Ord a, RealFrac a, Floating a, Enum a) => Int -> a -> [a]-harmonic_series_cps_derived k f1 =-    let f0 = T.cps_in_octave_above f1 (partial f1 k)-    in harmonic_series_cps f0---- | Harmonic series to /n/th harmonic (folded, duplicated removed).------ > harmonic_series_folded_r 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8]------ > let r = [0,105,204,386,551,702,841,969,1088]--- > map (round . ratio_to_cents) (harmonic_series_folded_r 17) == r-harmonic_series_folded_r :: Integer -> [Rational]-harmonic_series_folded_r n = nub (sort (map fold_ratio_to_octave_err [1 .. n%1]))---- | 'ratio_to_cents' variant of 'harmonic_series_folded'.-harmonic_series_folded_c :: Integer -> [Cents]-harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded_r--harmonic_series_folded :: Integer -> Tuning-harmonic_series_folded n = Tuning (Left (harmonic_series_folded_r n)) Nothing---- | @12@-tone tuning of first @21@ elements of the harmonic series.------ > tn_cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088]--- > tn_divisions harmonic_series_folded_21 == 11-harmonic_series_folded_21 :: Tuning-harmonic_series_folded_21 = harmonic_series_folded 21-
+ Music/Theory/Tuning/Hs.hs view
@@ -0,0 +1,81 @@+-- | Harmonic series+module Music.Theory.Tuning.Hs where++import Data.List {- base -}+import Data.Ratio {- base -}+import qualified Safe {- safe -}++import qualified Music.Theory.Pitch as T {- hmt -}+import Music.Theory.Tuning {- hmt -}+import Music.Theory.Tuning.Type {- hmt -}+++-- | Harmonic series to /n/th partial, with indicated octave.+--+-- > harmonic_series 17 2+harmonic_series :: Integer -> Maybe Rational -> Tuning+harmonic_series n o = Tuning (Left [1 .. n%1]) (fmap Left o)++-- | Harmonic series on /n/.+harmonic_series_cps :: (Num t, Enum t) => t -> [t]+harmonic_series_cps n = [n,n * 2 ..]++-- | /n/ elements of 'harmonic_series_cps'.+--+-- > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935]+-- > harmonic_series_cps_n 17 55 == r+harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a]+harmonic_series_cps_n n = take n . harmonic_series_cps++-- | Sub-harmonic series on /n/.+subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t]+subharmonic_series_cps n = map ((* n) . 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 :: (RealFrac a, Floating a, Enum a) => Int -> a -> [a]+harmonic_series_cps_derived k f1 =+    let f0 = T.cps_in_octave_above f1 (partial f1 k)+    in harmonic_series_cps f0++-- | Harmonic series to /n/th harmonic (folded, duplicated removed).+--+-- > harmonic_series_folded_r 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8]+--+-- > let r = [0,105,204,386,551,702,841,969,1088]+-- > map (round . ratio_to_cents) (harmonic_series_folded_r 17) == r+harmonic_series_folded_r :: Integer -> [Rational]+harmonic_series_folded_r n = nub (sort (map fold_ratio_to_octave_err [1 .. n%1]))++-- | 'ratio_to_cents' variant of 'harmonic_series_folded'.+harmonic_series_folded_c :: Integer -> [Cents]+harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded_r++harmonic_series_folded :: Integer -> Tuning+harmonic_series_folded n = Tuning (Left (harmonic_series_folded_r n)) Nothing++-- | @12@-tone tuning of first @21@ elements of the harmonic series.+--+-- > tn_cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088]+-- > tn_divisions harmonic_series_folded_21 == 11+harmonic_series_folded_21 :: Tuning+harmonic_series_folded_21 = harmonic_series_folded 21+
Music/Theory/Tuning/Load.hs view
@@ -3,15 +3,16 @@  import System.Random {- random -} -import qualified Music.Theory.Array.CSV as T-import qualified Music.Theory.Pitch as T+import qualified Music.Theory.Array.Csv as T {- hmt-base -}++import qualified Music.Theory.Pitch as T {- hmt -} 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.+-- (midi-note-number,cps-frequency) table from Csv file. -- -- > load_cps_tbl "/home/rohan/dr.csv" load_cps_tbl :: FilePath -> IO [(T.Midi,Double)]@@ -28,22 +29,22 @@  -- | 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)+type Load_Tuning_Opt = (String,Double,T.Midi)  -- | Load scala file and apply 'T.cps_midi_tuning_f'.-load_tuning_cps :: LOAD_TUNING_OPT -> 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 - 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 :: LOAD_TUNING_OPT -> 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 :: LOAD_TUNING_OPT -> 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)@@ -58,7 +59,7 @@     in (l !! i,g')  -- | Load tuning table with stateful selection function for one-to-many entries.-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 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@@ -67,7 +68,7 @@                              in (g',Just (from_cps e))     in fmap f (load_cps_tbl nm) -load_tuning_ty :: String -> LOAD_TUNING_OPT -> 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@@ -75,7 +76,7 @@       "tbl" -> load_tuning_tbl opt       _ -> error "cps|d12|tbl" -load_tuning_st_ty :: String -> LOAD_TUNING_OPT -> IO (T.Sparse_Midi_Tuning_ST_F StdGen)+load_tuning_st_ty :: String -> Load_Tuning_Opt -> IO (T.Sparse_Midi_Tuning_St_f StdGen) load_tuning_st_ty ty opt =     case ty of       "cps" -> fmap T.lift_sparse_tuning_f (load_tuning_cps opt)
Music/Theory/Tuning/Midi.hs view
@@ -4,7 +4,6 @@ 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 -}@@ -18,20 +17,20 @@ -- | (/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+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+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)+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 '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_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@@ -40,11 +39,11 @@ --   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'.+-- | '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 :: 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]@@ -56,15 +55,15 @@  -- | (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)+type Cps_Midi_Tuning = (Tuning,Double,T.Midi,Int) --- | 'Midi_Tuning_F' for 'CPS_Midi_Tuning'.  The function is sparse, it is only+-- | '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 :: 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)@@ -73,10 +72,10 @@ -- * Midi tuning tables.  -- | midi-note-number -> fractional-midi-note-number table, possibly sparse.-type MNN_FMNN_Table = [(Word8,Double)]+type Mnn_Fmnn_Table = [(Int,Double)] --- | Load 'MNN_FMNN_Table' from two-column CSV file.-mnn_fmnn_table_load_csv :: FilePath -> IO MNN_FMNN_Table+-- | 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@@ -84,15 +83,15 @@               _ -> 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)]+-- | 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@.+-- | 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 :: 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)@@ -101,8 +100,8 @@  -- * 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/.+-- | 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 =@@ -117,13 +116,13 @@       _ -> 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 :: 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 :: Mnn_Cps_Table -> Mnn_Cps_Table -> Midi_Tuning_f gen_dtt_lookup_f t0 t1 =     let m = M.fromList (gen_dtt_lookup_tbl t0 t1)     in T.cps_to_midi_detune . T.map_ix_err m
Music/Theory/Tuning/Partch.hs view
@@ -1,3 +1,4 @@+-- | Tuning, Harry Partch module Music.Theory.Tuning.Partch where  import qualified Data.Map.Strict as M {- containers -}@@ -14,7 +15,6 @@ -- | 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@@ -29,6 +29,9 @@ map_to_table k (nr,nc) m =   [[M.findWithDefault k (i,j) m | j <- [0 .. nc - 1]] | i <- [0 .. nr - 1]] +-- | 'map_to_table' of 'itd_map'.+--+-- > itd_tbl [4 .. 13] itd_tbl :: [Integer] -> [[Rational]] itd_tbl r =   let err = error "itd_tbl"@@ -38,76 +41,28 @@ {-  import Data.List {- base -}-import qualified Music.Theory.Array.MD as T {- hmt -}-import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Array.Text as T {- hmt -}+import qualified Music.Theory.Show as T {- hmt -} -pp tbl = putStrLn $ unlines $ intersperse "" $ T.md_table Nothing (map (map T.rational_pp) tbl)+pp tbl = putStrLn $ unlines $ T.table_pp T.table_opt_plain (map (map T.rational_pp) tbl)+pp (itd_tbl [4 .. 6])+pp (itd_tbl [4 .. 13])  $ itd 4 5 6   1/1     8/5     4/3-   5/4     1/1     5/3-   3/2     6/5     1/1-$--pp (itd_tbl [4 .. 6])--    --- --- ----      1 8/5 4/3--    5/4   1 5/3--    3/2 6/5   1-    --- --- ---- $ itd 4 5 6 7 8 9 10 11 12 13   1/1     8/5     4/3     8/7     1/1    16/9     8/5    16/11    4/3    16/13-   5/4     1/1     5/3    10/7     5/4    10/9     1/1    20/11    5/3    20/13-   3/2     6/5     1/1    12/7     3/2     4/3     6/5    12/11    1/1    24/13-   7/4     7/5     7/6     1/1     7/4    14/9     7/5    14/11    7/6    14/13-   1/1     8/5     4/3     8/7     1/1    16/9     8/5    16/11    4/3    16/13-   9/8     9/5     3/2     9/7     9/8     1/1     9/5    18/11    3/2    18/13-   5/4     1/1     5/3    10/7     5/4    10/9     1/1    20/11    5/3    20/13-  11/8    11/10   11/6    11/7    11/8    11/9    11/10    1/1    11/6    22/13-   3/2     6/5     1/1    12/7     3/2     4/3     6/5    12/11    1/1    24/13-  13/8    13/10   13/12   13/7    13/8    13/9    13/10   13/11   13/12    1/1- $--pp (itd_tbl [4 .. 13])--    ---- ----- ----- ---- ---- ---- ----- ----- ----- -------       1   8/5   4/3  8/7    1 16/9   8/5 16/11   4/3 16/13--     5/4     1   5/3 10/7  5/4 10/9     1 20/11   5/3 20/13--     3/2   6/5     1 12/7  3/2  4/3   6/5 12/11     1 24/13--     7/4   7/5   7/6    1  7/4 14/9   7/5 14/11   7/6 14/13--       1   8/5   4/3  8/7    1 16/9   8/5 16/11   4/3 16/13--     9/8   9/5   3/2  9/7  9/8    1   9/5 18/11   3/2 18/13--     5/4     1   5/3 10/7  5/4 10/9     1 20/11   5/3 20/13--    11/8 11/10  11/6 11/7 11/8 11/9 11/10     1  11/6 22/13--     3/2   6/5     1 12/7  3/2  4/3   6/5 12/11     1 24/13--    13/8 13/10 13/12 13/7 13/8 13/9 13/10 13/11 13/12     1--    ---- ----- ----- ---- ---- ---- ----- ----- ----- -----  -}
Music/Theory/Tuning/Polansky_1985c.hs view
@@ -1,5 +1,5 @@ -- | Larry Polansky. "Notes on Piano Study #5".--- _1/1, The Journal of the Just Intonation Newtork_, 1(4), Autumn 1985.+-- _1, The Journal of the Just Intonation Newtork_, 1(4), Autumn 1985. module Music.Theory.Tuning.Polansky_1985c where  import Music.Theory.Tuning.Type {- hmt -}@@ -7,10 +7,10 @@ -- | The tuning has four octaves, these ratios are per-octave. ps5_jpr_r :: [[Rational]] ps5_jpr_r =-    [[1/1, 21/20, 9/8, 6/5, 5/4,  4/3,   7/5, 3/2, 8/5,  5/3,  7/4, 15/8]-    ,[1/1, 21/20, 9/8, 6/5, 5/4,  4/3,   7/5, 3/2, 8/5,  5/3,  7/4, 15/8]-    ,[1/1, 33/32, 9/8, 6/5, 5/4, 21/16, 11/8, 3/2, 8/5, 13/8,  7/4, 15/8]-    ,[1/1, 21/20, 9/8, 7/6, 5/4,  4/3,  11/8, 3/2, 8/5, 27/16, 7/4, 15/8]]+    [[1, 21/20, 9/8, 6/5, 5/4,  4/3,   7/5, 3/2, 8/5,  5/3,  7/4, 15/8]+    ,[1, 21/20, 9/8, 6/5, 5/4,  4/3,   7/5, 3/2, 8/5,  5/3,  7/4, 15/8]+    ,[1, 33/32, 9/8, 6/5, 5/4, 21/16, 11/8, 3/2, 8/5, 13/8,  7/4, 15/8]+    ,[1, 21/20, 9/8, 7/6, 5/4,  4/3,  11/8, 3/2, 8/5, 27/16, 7/4, 15/8]]  {- | Four-octave tuning. @@ -30,6 +30,6 @@ -} ps5_jpr :: Tuning ps5_jpr =-    let f (m,n) = map (* m) n-        r = concat (map f (zip [1,2,4,8] ps5_jpr_r))+    let f m n = map (* m) n+        r = concat (zipWith f [1,2,4,8] ps5_jpr_r)     in Tuning (Left r) (Just (Left 4))
Music/Theory/Tuning/Rosenboom_1979.hs view
@@ -11,7 +11,7 @@ import qualified Music.Theory.List as T import qualified Music.Theory.Pitch as T import qualified Music.Theory.Pitch.Name as T-import qualified Music.Theory.Tuning.ET as T+import qualified Music.Theory.Tuning.Et as T import qualified Music.Theory.Tuning.Scala as Scala import qualified Music.Theory.Tuple as T @@ -36,7 +36,7 @@ -- | Actual scale, in CPS. -- -- > let r = [52,69,76,83,92,104,119,138,156,166,185,208,234,260,277,286,311,332,363]--- > in map round dr_scale == r+-- > map round dr_scale == r dr_scale :: [Double] dr_scale =     let f0 = T.octpc_to_cps (1::Int,8)@@ -46,38 +46,14 @@ -- > putStrLn (unlines (map (unwords . T.hs_r_pitch_pp 1)  dr_scale_tbl_12et)) -- > map (\(f,p,_,_,_) -> (T.pitch_to_midi p,f)) dr_scale_tbl_12et dr_scale_tbl_12et :: [T.HS_R T.Pitch]-dr_scale_tbl_12et = map T.nearest_12et_tone dr_scale--{---51.9 A♭1 51.9 0.0 0.0-69.2 C♯2 69.3 -0.1 -2.0-75.5 D2 73.4 2.1 48.7-83.1 E2 82.4 0.7 13.7-92.3 F♯2 92.5 -0.2 -3.9-103.8 A♭2 103.8 0.0 0.0-118.7 B♭2 116.5 2.1 31.2-138.4 C♯3 138.6 -0.2 -2.0-155.7 E♭3 155.6 0.2 2.0-166.1 E3 164.8 1.3 13.7-184.6 F♯3 185.0 -0.4 -3.9-207.7 A♭3 207.7 0.0 0.0-233.6 B♭3 233.1 0.5 3.9-259.6 C4 261.6 -2.1 -13.7-276.9 C♯4 277.2 -0.3 -2.0-285.5 D4 293.7 -8.1 -48.7-311.5 E♭4 311.1 0.4 2.0-332.2 E4 329.6 2.6 13.7-363.4 F♯4 370.0 -6.6 -31.2---}+dr_scale_tbl_12et = map (T.nearest_12et_tone_k0 (69,440)) dr_scale  -- > Scala.scale_verify dr_scale_scala -- > putStrLn $ unlines $ Scala.scale_pp dr_scale_scala 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)+    let f r (_,p,_,_,_) = (T.pitch_to_midi p :: Int,r)+        sq = zipWith f dr_tuning dr_scale_tbl_12et         g z k = case lookup k sq of                   Nothing -> (z,(k,z))                   Just r -> (r,(k,r))@@ -86,31 +62,7 @@  -- > putStrLn (unlines (map (unwords . T.hs_r_pitch_pp 1)  dr_scale_tbl_24et)) dr_scale_tbl_24et :: [T.HS_R T.Pitch]-dr_scale_tbl_24et = map T.nearest_24et_tone dr_scale--{---51.9 A♭1 51.9 0.0 0.0-69.2 C♯2 69.3 -0.1 -2.0-75.5 D𝄲2 75.6 -0.1 -1.3-83.1 E2 82.4 0.7 13.7-92.3 F♯2 92.5 -0.2 -3.9-103.8 A♭2 103.8 0.0 0.0-118.7 B𝄳2 120.0 -1.3 -18.8-138.4 C♯3 138.6 -0.2 -2.0-155.7 E♭3 155.6 0.2 2.0-166.1 E3 164.8 1.3 13.7-184.6 F♯3 185.0 -0.4 -3.9-207.7 A♭3 207.7 0.0 0.0-233.6 B♭3 233.1 0.5 3.9-259.6 C4 261.6 -2.1 -13.7-276.9 C♯4 277.2 -0.3 -2.0-285.5 D𝄳4 285.3 0.2 1.3-311.5 E♭4 311.1 0.4 2.0-332.2 E4 329.6 2.6 13.7-363.4 F𝄲4 359.5 3.9 18.8---}+dr_scale_tbl_24et = map (T.nearest_24et_tone_k0 (69,440)) dr_scale  dr_chords :: [[T.Pitch]] dr_chords =@@ -161,8 +113,8 @@     ,[(8,1),(1,10)]     ] --- > import Data.Function--- > import Data.List+-- > import Data.Function {- base -}+-- > import Data.List {- base -} -- > reverse (sortBy (compare `on` snd) dr_ratio_seq_hist) dr_ratio_seq_hist :: (Ord n,Num n) => [((n,n),Int)] dr_ratio_seq_hist = T.histogram (concat dr_ratio_seq)
Music/Theory/Tuning/Scala.hs view
@@ -2,7 +2,7 @@  See <http://www.huygens-fokker.org/scala/scl_format.html> for details. -This module succesfully parses all scales in v.89 of the scale library.+This module succesfully parses all scales in v.91 of the scale library.  -} module Music.Theory.Tuning.Scala where@@ -16,13 +16,13 @@ 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.Prime as T {- hmt -}+import qualified Music.Theory.Array.Csv as Csv {- hmt -}+import qualified Music.Theory.Directory as Directory {- hmt -}+import qualified Music.Theory.Either as Either {- hmt -}+import qualified Music.Theory.Function as Function {- hmt -}+import qualified Music.Theory.Io as Io {- hmt -}+import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Math.Prime as Prime {- 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 -}@@ -145,7 +145,7 @@  -- | Are the pitches in ascending sequence. is_scale_ascending :: Scale -> Bool-is_scale_ascending = T.is_ascending . map pitch_cents . scale_pitches+is_scale_ascending = List.is_ascending . map pitch_cents . scale_pitches  -- | Make scale pitches uniform, conforming to the most predominant pitch type. scale_uniform :: Epsilon -> Scale -> Scale@@ -172,7 +172,7 @@   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)+       Just Pitch_Ratio -> Just (1 : map (fromMaybe err . Either.from_right) p)        _ -> Nothing  -- | Erroring variant of 'scale_ratios_u.@@ -198,7 +198,7 @@  -- | 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+scale_eq_n k (_,_,d0,p0) (_,_,d1,p1) = d0 == d1 && length (p0 `intersect` p1) >= k  -- | Is `s1` a proper subset of `s2`. scale_sub :: Scale -> Scale -> Bool@@ -208,7 +208,7 @@ 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)+    in d0 == d1 && and (zipWith (~=) p0 p1)  -- * Parser @@ -231,7 +231,7 @@ filter_comments :: [String] -> [String] filter_comments =     map remove_eol_comments .-    filter (not . T.predicate_any [is_comment])+    filter (not . Function.predicate_any [is_comment])  -- | Pitches are either cents (with decimal point, possibly trailing) or ratios (with @/@). --@@ -260,13 +260,13 @@                in scale_verify_err scl       _ -> error "parse" --- * IO+-- * Io  -- | 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/89/scl"-scl_get_dir :: IO [String]+-- > setEnv "SCALA_SCL_DIR" "/home/rohan/data/scala/90/scl"+scl_get_dir :: IO [FilePath] scl_get_dir = fmap splitSearchPath (getEnv "SCALA_SCL_DIR")  -- | Lookup the @SCALA_SCL_DIR@ environment variable, which must exist, and derive the filepath.@@ -278,14 +278,14 @@   dir <- scl_get_dir   when (null dir) (error "scl_derive_filename: SCALA_SCL_DIR: nil")   when (hasExtension nm) (error "scl_derive_filename: name has extension")-  T.path_scan_err dir (nm <.> "scl")+  Directory.path_scan_err dir (nm <.> "scl")  -- | If the name is an absolute file path and has a @.scl@ extension, -- then return it, else run 'scl_derive_filename'. -- -- > scl_resolve_name "young-lm_piano"--- > 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 "/home/rohan/data/scala/90/scl/young-lm_piano.scl"+-- > scl_resolve_name "/home/rohan/data/scala/90/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"@@ -301,19 +301,18 @@ scl_load :: String -> IO Scale scl_load nm = do   fn <- scl_resolve_name nm-  s <- T.read_file_iso_8859_1 fn+  s <- Io.read_file_iso_8859_1 fn   return (parse_scl (takeBaseName nm) s)  {- | Load all @.scl@ files at /dir/, associate with file-name. -> db <- scl_load_dir_fn "/home/rohan/data/scala/89/scl"-> length db == 5050 -- v.89+> db <- scl_load_dir_fn "/home/rohan/data/scala/91/scl"+> length db == 5176 -- v.91 > map (\(fn,s) -> (takeFileName fn,scale_name s)) db- -} scl_load_dir_fn :: FilePath -> IO [(FilePath,Scale)] scl_load_dir_fn d = do-  fn <- T.dir_subset [".scl"] d+  fn <- Directory.dir_subset [".scl"] d   scl <- mapM scl_load fn   return (zip fn scl) @@ -331,7 +330,7 @@   r <- mapM scl_load_dir dir   return (concat r) --- * PP+-- * Pp  -- | <http://www.huygens-fokker.org/docs/scalesdir.txt> scales_dir_txt_tbl :: [Scale] -> [[String]]@@ -344,7 +343,7 @@ -- > 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)+scales_dir_txt_csv db = Csv.csv_table_pp id Csv.def_csv_opt (Nothing,scales_dir_txt_tbl db)  -- | Simple plain-text display of scale data. --@@ -394,11 +393,11 @@ scale_wr_dir :: FilePath -> Scale -> IO () scale_wr_dir dir scl = scale_wr (dir </> scale_name scl <.> "scl") scl --- * DIST+-- * Dist  -- | @scala@ distribution directory, given at @SCALA_DIST_DIR@. ----- > fmap (== "/home/rohan/opt/build/scala-22-pc64-linux") dist_get_dir+-- > setEnv "SCALA_DIST_DIR" "/home/rohan/opt/build/scala-22" dist_get_dir :: IO String dist_get_dir = getEnv "SCALA_DIST_DIR" @@ -408,14 +407,15 @@   d <- dist_get_dir   readFile (d </> nm) --- | 'fmap' 'lines' 'load_dist_file'------ > s <- load_dist_file_ln "intnam.par"--- > length s == 533 -- Scala 2.42p+{- | 'fmap' 'lines' 'load_dist_file'++> s <- load_dist_file_ln "intnam.par"+> length s == 565 -- Scala 2.46d+-} load_dist_file_ln :: FilePath -> IO [String] load_dist_file_ln = fmap lines . load_dist_file --- * QUERY+-- * Query  -- | Is scale just-intonation (ie. are all pitches ratios) scl_is_ji :: Scale -> Bool@@ -423,12 +423,12 @@  -- | 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+scl_ji_limit = maximum . map fst . concatMap Prime.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))))+  let r = map (List.dx_d 0) (List.rotations (List.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..]) @@ -471,10 +471,8 @@  -- | 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)+scl_find_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> [Scale] -> [Scale]+scl_find_ji cmp x = filter (scale_cmp_ji cmp x)  -- * Tuning @@ -483,11 +481,11 @@ scale_to_tuning :: Scale -> T.Tuning scale_to_tuning (_,_,_,p) =     case partitionEithers p of-      ([],r) -> let (r',o) = T.separate_last r+      ([],r) -> let (r',o) = List.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+      _ -> let (c,o) = List.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)+               o' = if o == Left 1200 || o == Right 2 then Nothing else Just (Either.either_swap o)            in T.Tuning (Right c') o'  -- | Convert 'T.Tuning' to 'Scale'.@@ -496,7 +494,7 @@ 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)]+        p' = either (map Right . tail) (map Left . tail) p ++ [Either.either_swap (T.tn_octave_def tn)]     in (nm,dsc,n,p')  -- | 'scale_to_tuning' of 'scl_load'.
+ Music/Theory/Tuning/Scala/Cli.hs view
@@ -0,0 +1,271 @@+-- | Command line interface to hmt/scala.+module Music.Theory.Tuning.Scala.Cli where++import Data.Char {- base -}+import Data.List {- base -}+import System.Environment {- base -}+import Text.Printf {- base -}++import qualified Music.Theory.Array.Text as T {- hmt-base -}+import qualified Music.Theory.Function as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Read as T {- hmt-base -}+import qualified Music.Theory.Show as T {- hmt-base -}++import qualified Music.Theory.Array.Csv.Midi.Mnd as T {- hmt -}+import qualified Music.Theory.Pitch as T {- hmt -}+import qualified Music.Theory.Pitch.Spelling.Table as T {- hmt -}+import qualified Music.Theory.Time.Seq as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.Et as T {- hmt -}+import qualified Music.Theory.Tuning.Midi as T {- hmt -}+import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}+import qualified Music.Theory.Tuning.Scala.Kbm as Kbm {- hmt -}+import qualified Music.Theory.Tuning.Scala.Functions as Functions {- hmt -}+import qualified Music.Theory.Tuning.Scala.Interval as Interval {- hmt -}+import qualified Music.Theory.Tuning.Scala.Mode as Mode {- hmt -}+import qualified Music.Theory.Tuning.Type as T {- hmt -}++type R = Double++db_stat :: IO ()+db_stat = do+  db <- Scala.scl_load_db+  let po = filter (== Just (Right 2)) (map Scala.scale_octave db)+      uf = filter Scala.is_scale_uniform db+      r = ["# entries        : " ++ show (length db)+          ,"# perfect-octave : " ++ show (length po)+          ,"# scale-uniform  : " ++ show (length uf)]+  putStrLn (unlines r)++-- > db_summarise (Just 15) (Just 65)+db_summarise :: Maybe Int -> Maybe Int -> IO ()+db_summarise nm_lim dsc_lim = do+  db <- Scala.scl_load_db+  let nm_seq = map Scala.scale_name db+      nm_max = maybe (maximum (map length nm_seq)) id nm_lim+      dsc_seq = map Scala.scale_description db+      fmt (nm,dsc) = printf "%-*s : %s" nm_max (take nm_max nm) (maybe dsc (flip take dsc) dsc_lim)+      tbl = map fmt (zip nm_seq dsc_seq)+  putStrLn (unlines tbl)++env :: IO ()+env = do+  scl_dir <- Scala.scl_get_dir+  dist_dir <- getEnv "SCALA_DIST_DIR"+  putStrLn ("SCALA_SCL_DIR = " ++ if null scl_dir then "NOT SET" else intercalate ":" scl_dir)+  putStrLn ("SCALA_DIST_DIR = " ++ if null dist_dir then "NOT SET" else dist_dir)++cut :: Maybe Int -> [a] -> [a]+cut lm s = maybe s (\n -> take n s) lm++search :: (IO [a], a -> String, a -> [String]) -> (Bool, Maybe Int) -> [String] -> IO ()+search (load_f,descr_f,stat_f) (ci,lm) txt = do+  db <- load_f+  let modify = if ci then map toLower else id+      txt' = map modify txt+      db' = filter (T.predicate_all (map isInfixOf txt') . modify . descr_f) db+  mapM_ (putStrLn . unlines . map (cut lm) . stat_f) db'++-- > search_scale (True,Nothing) ["xenakis"]+-- > search_scale (True,Just 75) ["lamonte","young"]+search_scale :: (Bool,Maybe Int) -> [String] -> IO ()+search_scale = search (Scala.scl_load_db,Scala.scale_description,Scala.scale_stat)++-- > search_mode (True,Nothing) ["xenakis"]+search_mode :: (Bool,Maybe Int) -> [String] -> IO ()+search_mode = search (fmap Mode.modenam_modes Mode.load_modenam,Mode.mode_description,Mode.mode_stat)++-- > stat_all Nothing+stat_all :: Maybe Int -> IO ()+stat_all character_limit = do+  db <- Scala.scl_load_db+  mapM_ (putStrLn . unlines . map (cut character_limit) . Scala.scale_stat) db++-- > stat_by_name Nothing "young-lm_piano"+stat_by_name :: Maybe Int -> FilePath -> IO ()+stat_by_name lm nm = do+  sc <- Scala.scl_load nm+  putStrLn (unlines (map (cut lm) (Scala.scale_stat sc)))++-- > rng_enum (60,72) == [60 .. 72]+rng_enum :: Enum t => (t,t) -> [t]+rng_enum (l,r) = [l .. r]++cps_tbl :: String -> T.Mnn_Cps_Table -> (T.Midi,T.Midi) -> IO ()+cps_tbl fmt tbl mnn_rng = do+  let cps_pp = T.double_pp 2+      cents_pp = T.double_pp 1+      gen_t i = (i,T.midi_to_pitch_ks i,T.lookup_err i tbl)+      t_pp (i,p,cps) =+          let ref = T.midi_to_cps i+              (_,nr,nr_cps,_,_) = T.nearest_12et_tone_k0 (69,440) cps+          in [show i+             ,cps_pp cps,T.pitch_pp_iso nr,cents_pp (T.cps_difference_cents nr_cps cps)+             ,cps_pp ref,T.pitch_pp_iso p,cents_pp (T.cps_difference_cents ref cps)]+      hdr = ["MNN"+            ,"CPS","ET12","CENTS-/+"+            ,"REF CPS","REF ET12","CENTS-/+"]+      dat = map (t_pp . gen_t) (rng_enum mnn_rng)+      ln = case fmt of+             "md" -> T.table_pp T.table_opt_simple (hdr : dat)+             "csv" -> map (intercalate ",") dat+             _ -> error "cps_tbl: fmt?"+  putStr (unlines ln)++-- > cps_tbl_d12 "md" ("young-lm_piano",-74.7,-3) (60,72)+cps_tbl_d12 :: String -> (String,T.Cents,T.Midi) -> (T.Midi,T.Midi) -> IO ()+cps_tbl_d12 fmt (nm,c,k) mnn_rng = do+  t <- Scala.scl_load_tuning nm :: IO T.Tuning+  let tbl = T.gen_cps_tuning_tbl (T.lift_tuning_f (T.d12_midi_tuning_f (t,c,k)))+  cps_tbl fmt tbl mnn_rng++-- > cps_tbl_cps "md" ("cet111",27.5,9,127-9) (69,69+25)+cps_tbl_cps :: String -> (String,R,T.Midi,Int) -> (T.Midi,T.Midi) -> IO ()+cps_tbl_cps fmt (nm,f0,k,n) mnn_rng = do+  t <- Scala.scl_load_tuning nm+  let tbl = T.gen_cps_tuning_tbl (T.cps_midi_tuning_f (t,f0,k,n))+  cps_tbl fmt tbl mnn_rng++csv_mnd_retune_d12 :: (String,T.Cents,T.Midi) -> FilePath -> FilePath -> IO ()+csv_mnd_retune_d12 (nm,c,k) in_fn out_fn = do+  t <- Scala.scl_load_tuning nm+  let retune_f = T.midi_detune_to_fmidi . T.d12_midi_tuning_f (t,c,k)+  m <- T.csv_midi_read_wseq in_fn :: IO (T.Wseq R (R,R,T.Channel,T.Param))+  let f (tm,(mnn,vel,ch,pm)) = (tm,(retune_f (floor mnn),vel,ch,pm))+  T.csv_mndd_write_wseq 4 out_fn (map f m)++-- > fluidsynth_tuning_d12 ("young-lm_piano",0,0) ("young-lm_piano",-74.7,-3)+fluidsynth_tuning_d12 :: (String,Int,Int) -> (String,T.Cents,T.Midi) -> IO ()+fluidsynth_tuning_d12 (fs_name,fs_bank,fs_prog) (nm,c,k) = do+  t <- Scala.scl_load_tuning nm :: IO T.Tuning+  let tun_f = T.d12_midi_tuning_f (t,c,k)+      pp_f n = let (mnn,dt) = tun_f n+                   cents = fromIntegral mnn * 100 + dt+                   cents_non_neg = if cents < 0 then 0 else cents+               in printf "tune %d %d %d %.2f" fs_bank fs_prog n cents_non_neg+      l = printf "tuning \"%s\" %d %d" fs_name fs_bank fs_prog : map pp_f [0 .. 127]+  putStrLn (unlines l)++{-+import Data.Int {- base -}+import Data.Word {- base -}++int_to_int8 :: Int -> Int8+int_to_int8 = fromIntegral++int8_to_word8 :: Int8 -> Word8+int8_to_word8 = fromIntegral++midi_tbl_binary_mnn_cents_tuning_d12 :: FilePath -> (String,T.Cents,Int) -> IO ()+midi_tbl_binary_mnn_cents_tuning_d12 fn (nm,c,k) = do+  t <- Scala.scl_load_tuning nm :: IO T.Tuning+  let tun_f = T.d12_midi_tuning_f (t,c,k)+      pp_f n = let (mnn,dt) = T.midi_detune_normalise (tun_f n)+               in [int_to_int8 mnn,int_to_int8 (round dt)]+  B.writeFile fn (B.pack (map int8_to_word8 (concatMap pp_f [0 .. 127])))+-}++{-+> midi_tbl_tuning_d12 "freq" ("meanquar",0,0)+> midi_tbl_tuning_d12 "fmidi" ("meanquar",0,0)+> midi_tbl_tuning_d12 "mts" ("young-lm_piano",-74.7,-3)+-}+midi_tbl_tuning_d12 :: String -> (String,T.Cents,T.Midi) -> IO ()+midi_tbl_tuning_d12 typ (nm,c,k) = do+  t <- Scala.scl_load_tuning nm :: IO T.Tuning+  let tun_f = T.d12_midi_tuning_f (t,c,k)+      pp_f n =+        case typ of+          "fmidi" -> printf "%3d,%10.6f" n (T.midi_detune_to_fmidi (tun_f n))+          "freq" -> printf "%3d,%10.4f" n (T.midi_detune_to_cps (tun_f n))+          "mts" ->+            let (mnn,dt) = T.midi_detune_normalise_positive (tun_f n)+            in printf "%3d,%3d,%7.4f" n (mnn `mod` 0x80) dt+          _ -> error "midi_tbl_tuning_d12"+  putStr (unlines (map pp_f [0 .. 127]))++ratio_cents_pp :: Rational -> String+ratio_cents_pp = show . (round :: Double -> Int) . T.ratio_to_cents++-- > intnam_lookup [7/4,7/6,9/8,13/8]+intnam_lookup :: [Rational] -> IO ()+intnam_lookup r_sq = do+  let f db r = let nm = maybe "*Unknown*" snd (Interval.intnam_search_ratio db r)+               in concat [T.ratio_pp r," = ",nm," = ",ratio_cents_pp r]+  db <- Interval.load_intnam+  mapM_ (putStrLn . f db) r_sq++-- > intnam_search "didymus"+intnam_search :: String -> IO ()+intnam_search txt = do+  db <- Interval.load_intnam+  let f (r,nm) = concat [T.ratio_pp r," = ",nm," = ",ratio_cents_pp r]+  mapM_ (putStrLn . f) (Interval.intnam_search_description_ci db txt)++kbm_tbl :: String -> String -> String -> IO ()+kbm_tbl ty scl_nm kbm_nm = do+  scl <- Scala.scl_load scl_nm+  kbm <- Kbm.kbm_load kbm_nm+  let tbl = case ty of+        "cps" -> Kbm.kbm_cps_tbl kbm scl+        "fmidi" -> Kbm.kbm_fmidi_tbl kbm scl+        _ -> error "kbm_tbl: unknown type"+      fmt (i,j) = printf "%d,%.4f" i j+      txt = unlines (map fmt tbl)+  putStrLn txt++-- * Main++help :: [String]+help =+    ["cps-tbl md|csv cps name:string f0:real mnn0:int gamut:int mnn-l:int mnn-r:int"+    ,"cps-tbl md|csv d12 name:string cents:real mnn:int mnn-l:int mnn-r:int"+    ,"csv-mnd-retune d12 name:string cents:real mnn:int input-file output-file"+    ,"db stat"+    ,"db summarise nm-lm|nil dsc-lm|nil"+    ,"env"+    ,"fluidsynth d12 scl-name:string cents:real mnn:int fs-name:string fs-bank:int fs-prog:int"+    ,"intervals {half-matrix|list|matrix} {cents|ratios} scale-name:string"+    ,"intname lookup interval:rational..."+    ,"intname search text:string"+    ,"kbm table {cps | fmidi} scala-name:string kbm-name:string"+    ,"midi-table fmidi|freq|mts d12 name:string cents:real mnn:int"+    ,"search scale|mode ci|cs lm|nil text:string..."+    ,"stat all lm|nil"+    ,"stat scale lm|nil name:string|file-path"+    ,""+    ,"  lm:int = line character limit"]++nil_or_read :: Read a => String -> Maybe a+nil_or_read s = if s == "nil" then Nothing else Just (T.read_err s)++scala_cli :: [String] -> IO ()+scala_cli arg = do+  let usage = putStrLn (unlines help)+  case arg of+    ["cps-tbl",fmt,"cps",nm,f0,k,n,l,r] -> cps_tbl_cps fmt (nm,read f0,read k,read n) (read l,read r)+    ["cps-tbl",fmt,"d12",nm,c,k,l,r] -> cps_tbl_d12 fmt (nm,read c,read k) (read l,read r)+    ["csv-mnd-retune","d12",nm,c,k,in_fn,out_fn] -> csv_mnd_retune_d12 (nm,read c,read k) in_fn out_fn+    ["db","stat"] -> db_stat+    ["db","summarise",nm_lim,dsc_lim] -> db_summarise (nil_or_read nm_lim) (nil_or_read dsc_lim)+    ["env"] -> env+    ["fluidsynth","d12",scl_nm,c,k,fs_nm,fs_bank,fs_prog] ->+        fluidsynth_tuning_d12 (fs_nm,read fs_bank,read fs_prog) (scl_nm,read c,read k)+    ["intervals","half-matrix",'c':_,k,nm] -> Functions.intervals_half_matrix_cents (read k) nm+    ["intervals","half-matrix",'r':_,nm] -> Functions.intervals_half_matrix_ratios nm+    ["intervals","list",'r':_,nm] -> Functions.intervals_list_ratios nm+    ["intervals","matrix",'c':_,k,nm] -> Functions.intervals_matrix_cents (read k) nm+    ["intervals","matrix",'r':_,nm] -> Functions.intervals_matrix_ratios nm+    "intnam":"lookup":r_sq -> intnam_lookup (map T.read_ratio_with_div_err r_sq)+    ["intnam","search",txt] -> intnam_search txt+    ["kbm","table",ty,scl_nm,kbm_nm] -> kbm_tbl ty scl_nm kbm_nm+    ["midi-table",typ,"d12",scl_nm,c,k] -> midi_tbl_tuning_d12 typ (scl_nm,read c,read k)+    "search":ty:ci:lm:txt ->+        case ty of+          "scale" -> search_scale (ci == "ci",nil_or_read lm) txt+          "mode" -> search_mode (ci == "ci",nil_or_read lm) txt+          _ -> usage+    ["stat","all",lm] -> stat_all (nil_or_read lm)+    ["stat","scale",lm,nm] -> stat_by_name (nil_or_read lm) nm+    _ -> usage
+ Music/Theory/Tuning/Scala/Functions.hs view
@@ -0,0 +1,123 @@+-- | Scala functions, <http://www.huygens-fokker.org/scala/help.htm>+module Music.Theory.Tuning.Scala.Functions where++import Data.List {- base -}++import qualified Music.Theory.Array.Text as Text {- hmt -}+import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Math as Math {- hmt -}+import qualified Music.Theory.Show as Show {- hmt -}+import qualified Music.Theory.Tuning as Tuning {- hmt -}+import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}+import qualified Music.Theory.Tuning.Scala.Interval as Interval {- hmt -}++{- | <http://www.huygens-fokker.org/scala/help.htm#EQUALTEMP>++> map round (equaltemp 12 2 13) == [0,100,200,300,400,500,600,700,800,900,1000,1100,1200]+> map round (equaltemp 13 3 14) == [0,146,293,439,585,732,878,1024,1170,1317,1463,1609,1756,1902]+> map round (equaltemp 12.5 3 14) == [0,152,304,456,609,761,913,1065,1217,1369,1522,1674,1826,1978]+-}+equaltemp :: Double -> Double -> Int -> [Double]+equaltemp division octave scale_size =+  let step = Tuning.fratio_to_cents octave / division+  in take scale_size [0,step ..]++{- | <http://www.huygens-fokker.org/scala/help.htm#LINEARTEMP>++> let py = lineartemp 12 2 () (3/2 :: Rational) 3+> py == [1/1,2187/2048,9/8,32/27,81/64,4/3,729/512,3/2,6561/4096,27/16,16/9,243/128,2/1]+-}+lineartemp :: (Fractional n, Ord n) => Int -> n -> () -> n -> Int -> [n]+lineartemp scale_size octave _degree_of_fifth fifth down =+  let geom i m = i : geom (i * m) m+      geom_oct i = map Tuning.fold_ratio_to_octave_err . geom i+      lhs = take (down + 1) (geom_oct 1 (1 / fifth))+      rhs = tail (take (scale_size - down) (geom_oct 1 fifth))+  in sort (lhs ++ rhs) ++ [octave]++-- * INTERVALS++interval_hist_ratios :: (Fractional t,Ord t) => [t] -> [(t,Int)]+interval_hist_ratios x = List.histogram [(if p < q then p * 2 else p) / q | p <- x, q <- x, p /= q]++intervals_list_ratios_r :: Interval.INTNAM -> [Rational] -> IO ()+intervals_list_ratios_r nam_db rat = do+  let hst = interval_hist_ratios rat+      ln (r,n) = let nm = maybe "" snd (Interval.intnam_search_ratio nam_db r)+                     c = Tuning.ratio_to_cents r+                     i = Math.real_round_int (c / 100)+                 in [show i,show n,Show.ratio_pp r,Show.real_pp 1 c,nm]+      tbl = map ln hst+      pp = Text.table_pp Text.table_opt_plain+  putStrLn (unlines (pp tbl))++{- | <http://www.huygens-fokker.org/scala/help.htm#SHOW_INTERVALS>++> mapM_ intervals_list_ratios (words "pyth_12 kepler1")+-}+intervals_list_ratios :: String -> IO ()+intervals_list_ratios scl_nm = do+  nam_db <- Interval.load_intnam+  scl <- Scala.scl_load scl_nm+  intervals_list_ratios_r nam_db (tail (Scala.scale_ratios_req scl))++-- * INTERVALS++-- | Given interval function (ie. '-' or '/') and scale generate interval half-matrix.+interval_half_matrix :: (t -> t -> u) -> [t] -> [[u]]+interval_half_matrix interval_f =+  let tails' = filter ((>= 2) . length) . tails+      f l = case l of+              [] -> []+              i : l' -> map (`interval_f` i) l'+  in map f . tails'++interval_half_matrix_tbl :: (t -> String) -> (t -> t -> t) -> [t] -> [[String]]+interval_half_matrix_tbl show_f interval_f scl =+    let f n l = replicate n "" ++ map show_f l+    in zipWith f [1..] (interval_half_matrix interval_f scl)++intervals_half_matrix :: (Scala.Scale -> [t]) -> (t -> t -> t) -> (t -> String) -> String -> IO ()+intervals_half_matrix scl_f interval_f show_f nm = do+  scl <- Scala.scl_load nm+  let txt = interval_half_matrix_tbl show_f interval_f (scl_f scl)+      pp = Text.table_pp Text.table_opt_plain+  putStrLn (unlines (pp txt))++-- > mapM_ (intervals_half_matrix_cents 0) (words "pyth_12 kepler1")+intervals_half_matrix_cents :: Int -> String -> IO ()+intervals_half_matrix_cents k = intervals_half_matrix Scala.scale_cents (-) (Show.real_pp k)++-- > mapM_ (intervals_half_matrix_ratios) (words "pyth_12 kepler1")+intervals_half_matrix_ratios :: String -> IO ()+intervals_half_matrix_ratios = intervals_half_matrix Scala.scale_ratios_req (/) Show.ratio_pp++{-+> r = [3*5,3*7,3*11,5*7,5*11,7*11]+> r = let u = [1,3,5,7,9,11] in [i*j*k | i <- u, j <- u, k <- u, i < j, j < k]+> intervals_matrix_wr Show.ratio_pp (interval_matrix_ratio r)+-}+interval_matrix_ratio :: [Rational] -> [[Rational]]+interval_matrix_ratio x = let f i = map (\j -> if j < i then j * 2 / i else j / i) x in map f x++interval_matrix_cents :: [Tuning.Cents] -> [[Tuning.Cents]]+interval_matrix_cents x = let f i = map (\j -> if j < i then j + 1200 - i else j - i) x in map f x++intervals_matrix_wr :: (t -> String) -> [[t]] -> IO ()+intervals_matrix_wr pp_f x = do+  let txt = map (map pp_f) x+      pp = Text.table_pp Text.table_opt_plain+  putStrLn (unlines (pp txt))++intervals_matrix :: (Scala.Scale -> [t]) -> ([t] -> [[t]]) -> (t -> String) -> String -> IO ()+intervals_matrix scl_f tbl_f pp_f nm = do+  scl <- Scala.scl_load nm+  intervals_matrix_wr pp_f (tbl_f (scl_f scl))++-- > mapM_ (intervals_matrix_cents 0) (words "pyth_12 kepler1")+intervals_matrix_cents :: Int -> String -> IO ()+intervals_matrix_cents k = intervals_matrix Scala.scale_cents interval_matrix_cents (Show.real_pp k)++-- > mapM_ intervals_matrix_ratios (words "pyth_12 kepler1")+intervals_matrix_ratios :: String -> IO ()+intervals_matrix_ratios = intervals_matrix Scala.scale_ratios_req interval_matrix_ratio Show.ratio_pp
Music/Theory/Tuning/Scala/Interval.hs view
@@ -3,6 +3,7 @@  import Data.Char {- base -} import Data.List {- base -}+import Data.Maybe {- base -}  import qualified Music.Theory.Read as Read {- hmt -} import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}@@ -20,10 +21,27 @@ > 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 db (64/49) == Just (64 % 49,"=2 septatones or septatonic major third")+> map (intnam_search_ratio db) [3/2,4/3,7/4,7/6,9/7,9/8,12/7,14/9]+> import Data.Maybe {- base -}+> mapMaybe (intnam_search_ratio db) [567/512,147/128,21/16,1323/1024,189/128,49/32,441/256,63/32] -} intnam_search_ratio :: INTNAM -> Rational -> Maybe INTERVAL intnam_search_ratio (_,i) x = find ((== x) . fst) i++{- | Lookup approximate ratio in 'INTNAM' given espilon.++> r = [Just (3/2,"perfect fifth"),Just (64/49,"=2 septatones or septatonic major third")]+> map (intnam_search_fratio 0.0001 db) [1.5,1.3061] == r+-}+intnam_search_fratio :: (Fractional n,Ord n) => n -> INTNAM -> n -> Maybe INTERVAL+intnam_search_fratio epsilon (_,i) x =+  let near p q = abs (p - q) < epsilon+  in find (near x . fromRational . fst) i++-- | Lookup name of interval, or error.+intnam_search_ratio_name_err :: INTNAM -> Rational -> String+intnam_search_ratio_name_err db = snd . fromJust . intnam_search_ratio db  -- | Lookup interval name in 'INTNAM', ci = case-insensitive. --
− Music/Theory/Tuning/Scala/KBM.hs 
@@ -1,132 +0,0 @@-{- | Scala "keyboard mapping" files (.kbm) and related data structure.--<http://www.huygens-fokker.org/scala/help.htm#mappings>--}-module Music.Theory.Tuning.Scala.KBM where--import qualified Music.Theory.Directory as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Tuning.Scala as T {- hmt -}--{- | Scala keyboard mapping--(sz,(m0,mN),mC,(mF,f),o,m)--- sz      = size of map, the pattern repeats every so many keys-- (m0,mN) = the first and last midi note numbers to retune-- mC      = the middle note where the first entry of the mapping is mapped to-- (mF,f)  = the reference midi-note for which a frequency is given, ie. (69,440)-- o       = scale degree to consider as formal octave-- m       = mapping, numbers represent scale degrees mapped to keys, Nothing indicates no mapping---}-type KBM = (Int,(Int,Int),Int,(Int,Double),Int,[Maybe Int])---- | Is /mnn/ in range?-kbm_in_rng :: KBM -> Int -> Bool-kbm_in_rng (_,(m0,mN),_,_,_,_) mnn = mnn >= m0 && mnn <= mN---- | Is /kbm/ linear?, ie. is size zero? (formal-octave may or may not be zero)-kbm_is_linear :: KBM -> Bool-kbm_is_linear (sz,_,_,_,_o,_) = sz == 0 -- && o == 0--{- | Given kbm and midi-note-number lookup (octave,scale-degree).--> k <- kbm_load_dist "example.kbm" -- 12-tone scale-> k <- kbm_load_dist "a440.kbm" -- linear-> k <- kbm_load_dist "white.kbm" -- 7-tone scale on white notes-> k <- kbm_load_dist "black.kbm" -- 5-tone scale on black notes-> k <- kbm_load_dist "128.kbm"--> map (kbm_lookup k) [48 .. 72]---}-kbm_lookup :: KBM -> Int -> Maybe (Int,Int)-kbm_lookup kbm mnn =-  if not (kbm_in_rng kbm mnn)-  then Nothing-  else if kbm_is_linear kbm-       then Just (0,mnn)-       else let (sz,(_m0,_mN),mC,(_mF,_f),_o,m) = kbm-                (oct,ix) = ((mnn - mC) `divMod` sz)-            in maybe Nothing (\dgr -> Just (oct,dgr)) (m !! ix)---- | Return the triple (mF,kbm_lookup k mF,f).  The lookup for mF is not-nil by definition.------ > kbm_lookup_mF k-kbm_lookup_mF :: KBM -> (Int,(Int,Int),Double)-kbm_lookup_mF k@(_,_,_,(mF,f),_,_) =-  case kbm_lookup k mF of-    Nothing -> error "kbm_lookup_mF?"-    Just r -> (mF,r,f)---- | Parser for scala .kbm file.-kbm_parse :: String -> KBM-kbm_parse s =-  let f x = case x of-              "x" -> Nothing-              _ -> Just (read x)-      to_m sz = T.pad_right_no_truncate Nothing sz . map f -- _err -- some scala .kbm have |m| > sz?-  in case T.filter_comments (lines s) of-       i1:i2:i3:i4:i5:d1:i6:m ->-         let sz = read i1-         in (sz,(read i2,read i3),read i4,(read i5,read d1),read i6,to_m sz m)-       _ -> error "kbm_parse?"---- | 'kbm_parse' of 'readFile'-kbm_load :: FilePath -> IO KBM-kbm_load = fmap kbm_parse . readFile--{- | 'kbm_parse' of 'T.load_dist_file'--> kbm_load_dist "example.kbm"-> kbm_load_dist "bp.kbm"-> kbm_load_dist "7.kbm" -- error-> kbm_load_dist "8.kbm" -- error-> kbm_load_dist "white.kbm" -- error-> kbm_load_dist "black.kbm" -- error-> kbm_load_dist "128.kbm"-> kbm_load_dist "a440.kbm"-> kbm_load_dist "61.kbm"--}-kbm_load_dist :: FilePath -> IO KBM-kbm_load_dist = fmap kbm_parse . T.load_dist_file--kbm_load_dir_fn :: FilePath -> IO [(FilePath, KBM)]-kbm_load_dir_fn d = do-  fn <- T.dir_subset [".kbm"] d-  kbm <- mapM kbm_load fn-  return (zip fn kbm)--{- | Load all .kbm files at scala DIST dir.--> db <- kbm_load_dist_dir_fn-> x = map (\(fn,(sz,_,_,_,o,m)) -> (System.FilePath.takeFileName fn,sz,length m,o)) db-> filter (\(_,i,j,_) -> i < j) x-> filter (\(_,i,_,k) -> i == 0 && k == 0) x--> map (\(fn,k) -> (System.FilePath.takeFileName fn,kbm_lookup_mF k)) db--}-kbm_load_dist_dir_fn :: IO [(FilePath, KBM)]-kbm_load_dist_dir_fn = T.dist_get_dir >>= kbm_load_dir_fn--{- | Pretty-printer for scala .kbm file.--> m <- kbm_load_dist "7.kbm"-> kbm_parse (kbm_pp m) == m--}-kbm_pp :: KBM -> String-kbm_pp (i1,(i2,i3),i4,(i5,d1),i6,m) =-  let from_m = map (maybe "x" show)-  in unlines ([show i1,show i2,show i3,show i4,show i5,show d1,show i6] ++ from_m m)---- | 'writeFile' of 'kbm_pp'-kbm_wr :: FilePath -> KBM -> IO ()-kbm_wr fn = writeFile fn . kbm_pp--{- | Standard 12-tone mapping with A=440hz (ie. example.kbm)--> fmap (== kbm_d12_a440) (kbm_load_dist "example.kbm")--}-kbm_d12_a440 :: KBM-kbm_d12_a440 = (12,(0,127),60,(69,440.0),12,map Just [0 .. 11])
+ Music/Theory/Tuning/Scala/Kbm.hs view
@@ -0,0 +1,217 @@+{- | Scala "keyboard mapping" files (.kbm) and related data structure.++<http://www.huygens-fokker.org/scala/help.htm#mappings>+-}+module Music.Theory.Tuning.Scala.Kbm where++import Data.List {- base -}+import Data.Maybe {- base -}+import System.FilePath {- filepath -}+import Text.Printf {- base -}++import qualified Music.Theory.Directory as Directory {- hmt -}+import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Pitch as Pitch {- hmt -}+import qualified Music.Theory.Tuning as Tuning {- hmt -}+import qualified Music.Theory.Tuning.Scala as Scala {- 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])++-- | Pretty-printer for scala .kbm file.+kbm_pp :: Kbm -> String+kbm_pp (sz,(m0,mN),mC,(mF,f),o,m) =+  unlines+  [printf "size = %d" sz+  ,printf "note-range = (%d,%d)" m0 mN+  ,printf "note-center = %d" mC+  ,printf "note-reference = (%d,%f)" mF f+  ,printf "formal-octave = %d" o+  ,printf "map = [%s] #%d" (intercalate "," (map (maybe "x" show) m)) (length m)]++-- | 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 fmap (\dgr -> (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 = List.pad_right_no_truncate Nothing sz . map f -- _err -- some scala .kbm have |m| > sz?+  in case Scala.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_file :: FilePath -> IO Kbm+kbm_load_file = fmap kbm_parse . readFile++{- | 'kbm_parse' of 'Scala.load_dist_file'++> pp nm = kbm_load_dist nm >>= \x -> putStrLn (kbm_pp x)+> pp "example"+> pp "bp"+> pp "7" -- error -- 12/#13+> pp "8" -- error -- 12/#13+> pp "white" -- error -- 12/#13+> pp "black" -- error -- 12/#13+> pp "128"+> pp "a440"+> pp "61"+-}+kbm_load_dist :: String -> IO Kbm+kbm_load_dist nm = fmap kbm_parse (Scala.load_dist_file (nm <.> "kbm"))++-- | If /nm/ is a file name (has a .kbm) extension run 'kbm_load_file' else run 'kbm_load_dist'.+kbm_load :: String -> IO Kbm+kbm_load nm = if hasExtension nm then kbm_load_file nm else kbm_load_dist nm++-- | Load all .kbm files at directory.+kbm_load_dir_fn :: FilePath -> IO [(FilePath, Kbm)]+kbm_load_dir_fn d = do+  fn <- Directory.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+> length db == 41+> x = map (\(fn,(sz,_,_,_,o,m)) -> (System.FilePath.takeFileName fn,sz,length m,o)) db+> filter (\(_,i,j,_) -> i < j) x -- size < map-length+> filter (\(_,i,_,k) -> i == 0 && k == 0) x -- size and formal octave both zero++> 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 = Scala.dist_get_dir >>= kbm_load_dir_fn++{- | Pretty-printer for scala .kbm file.++> m <- kbm_load_dist "7.kbm"+> kbm_parse (kbm_format m) == m+> putStrLn $ kbm_pp m+-}+kbm_format :: Kbm -> String+kbm_format (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_format'+kbm_wr :: FilePath -> Kbm -> IO ()+kbm_wr fn = writeFile fn . kbm_format++{- | Standard 12-tone mapping with A=440hz (ie. example.kbm)++> fmap (== kbm_d12_a440) (kbm_load_dist "example.kbm")+> putStrLn $ kbm_pp kbm_d12_a440+-}+kbm_d12_a440 :: Kbm+kbm_d12_a440 = (12,(0,127),60,(69,440.0),12,map Just [0 .. 11])++kbm_d12_c256 :: Kbm+kbm_d12_c256 = (12,(0,127),60,(60,256.0),12,map Just [0 .. 11])++-- | Given size and note-center calculate relative octave and key+--   number (not scale degree) of the zero entry.+--+-- > map (kbm_k0 12) [59,60,61] == [(-4,1),(-5,0),(-5,11)]+kbm_k0 :: Int -> Int -> (Int,Int)+kbm_k0 sz mC = let (o,r) = mC `quotRem` sz in (negate o,negate r `mod` sz)++-- | Given size and note-center calculate complete octave and key+-- number sequence (ie. for entries 0 - 127).+--+-- > map (zip [0..] . kbm_oct_key_seq 12) [59,60,61]+kbm_oct_key_seq :: Kbm -> [(Int,(Int,Int))]+kbm_oct_key_seq (sz,(m0,mN),mC,(_mF,_f),_o,_m) =+  let (o0,k0) = kbm_k0 sz mC+      dgr = map (`mod` sz) (take 128 [k0 ..])+      upd o j = if j == 0 then (o + 1,(o + 1,j)) else (o,(o,j))+      key_seq = snd (mapAccumL upd (o0 - 1) dgr)+  in zip [m0 .. ] (take (mN - m0 + 1) (drop m0 key_seq))++-- | Given Kbm and SCL calculate frequency of note-center.+kbm_mC_freq :: Kbm -> Scala.Scale -> Double+kbm_mC_freq (sz,(_m0,_mN),mC,(mF,f),_o,m) scl =+  let dist_k = (mF - mC) `mod` sz+      dgr = fromMaybe (error "kbm_mC_freq") (m !! dist_k)+      c = Scala.scale_cents scl !! dgr+  in Tuning.cps_shift_cents f (- c)++-- | Given Kbm and SCL calculate fractional midi note-numbers for each key.+kbm_fmidi_tbl :: Kbm -> Scala.Scale -> [(Int, Double)]+kbm_fmidi_tbl kbm scl =+  let (_sz,(_m0,_mN),_mC,(_mF,_f),o,m) = kbm+      mC_freq = kbm_mC_freq kbm scl+      mC_fmidi = Pitch.cps_to_fmidi mC_freq+      key_seq = kbm_oct_key_seq kbm+      c = Scala.scale_cents scl+      oct_cents = c !! o+      oct_key_to_cents (oct,key) = maybe 0 (c !!) (m !! key) + (fromIntegral oct * oct_cents)+  in map (\(mnn,oct_key) -> (mnn,mC_fmidi + (oct_key_to_cents oct_key / 100.0))) key_seq++-- | Given Kbm and SCL calculate frequencies for each key.+kbm_cps_tbl :: Kbm -> Scala.Scale -> [(Int, Double)]+kbm_cps_tbl kbm = let f (k,n) = (k,Tuning.fmidi_to_cps n) in map f . kbm_fmidi_tbl kbm++{-++scl <- Scala.scl_load "young-lm_piano"+scl <- Scala.scl_load "meanquar"+scl <- Scala.scl_load "et12"+kbm <- kbm_load "example" -- d12_a440 -- kbm_d12_a440 kbm_d12_c256++kbm_fmidi_tbl kbm scl+kbm_cps_tbl kbm scl++-}
Music/Theory/Tuning/Scala/Meta.hs view
@@ -55,6 +55,7 @@     ,"grady_centaur"     ,"grady_centaur17"     ,"grady_centaur19"])+  ,("Hahn, Paul",words "duohex hahn_7 hahn9 hahnmaxr indian-hahn") -- hahn_g mean14a   ,("Harrison, Lou"    ,["dudon_slendro_matrix" -- NON-UNIQ     ,"harrison_5"@@ -77,15 +78,16 @@     ,"harrison_slye"     ,"harrison_songs"     ,"hexany10"+    ,"hirajoshi2"     ,"korea_5"+    ,"olympos"     ,"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+    ,"slendro5_1","slendro5_2"+    ,"slendro_7_1","slendro_7_2","slendro_7_3","slendro_7_4"+    -- "slendro_laras" -- NON-OCT+    ,"tranh"])   ,("Johnston, Ben"    ,["johnston"     ,"johnston_21"@@ -135,17 +137,35 @@     -- "pyth_31" "pyth_sev" "pyth_third" NOT-JI     ])   ,("Riley, Terry",words "riley_albion riley_rosary")+  ,("Smith, Gene Ward",["smithgw_15highschool1","smithgw_15highschool2","smithgw_18","smithgw_19highschool1","smithgw_19highschool2","smithgw_21","smithgw_22highschool","smithgw_58","smithgw_9","smithgw_ball","smithgw_ball2","smithgw_circu","smithgw_decab","smithgw_decac","smithgw_decad","smithgw_diff13","smithgw_dwarf6_7","smithgw_ennon13","smithgw_ennon15","smithgw_ennon28","smithgw_ennon43","smithgw_euclid3","smithgw_glamma","smithgw_glumma","smithgw_gm","smithgw_hahn12","smithgw_hahn15","smithgw_hahn16","smithgw_hahn19","smithgw_hahn22","smithgw_indianred","smithgw_majraj1","smithgw_majraj2","smithgw_majraj3","smithgw_majsyn1","smithgw_majsyn2","smithgw_majsyn3","smithgw_meandin","smithgw_meanred","smithgw_mir22","smithgw_monzoblock37","smithgw_orw18r","smithgw_pel1","smithgw_pel3","smithgw_pris","smithgw_prisa","smithgw_ragasyn1","smithgw_ratwell","smithgw_rectoo","smithgw_red72_11geo","smithgw_red72_11pro","smithgw_sc19","smithgw_scj22a","smithgw_scj22b","smithgw_scj22c","smithgw_smalldi11","smithgw_smalldi19a","smithgw_smalldi19b","smithgw_smalldi19c","smithgw_star","smithgw_star2","smithgw_syndia2","smithgw_syndia3","smithgw_syndia4","smithgw_syndia6","smithgw_well1","smithgw_wiz28","smithgw_wiz34","smithgw_wiz38"])   ,("Tenney, James",words "mund45 tenney_8 tenney_11 tenn41a tenn41b tenn41c")   ,("Wilson, Erv"    ,["chin_7"     ,"ckring9"     ,"diamond7-13"+    ,"dodeceny","dorian_diat2inv","hypol_diatinv"+    ,"dkring3"+    ,"efg33357","efg3335711","efg35711"+    ,"eikosany"+    ,"erlich9"+    ,"harm6","harm8","harm9","harm14","harm15"     ,"hexany_union"+    ,"indian-magrama"+    ,"malkauns"+    ,"malcolme"     ,"novaro15"     ,"partch_29"-    ,"ptolemy_diat2","ptolemy_idiat"-    ,"slendro5_2"+    ,"ptolemy","ptolemy_diat2","ptolemy_idiat"+    ,"slendro5_1","slendro5_2","slendro_7_4"+    ,"steldek1","steldek1s","steldek2","steldek2s"+    ,"steldia"+    ,"steleik1","steleik1s","steleik2","steleik2s"     ,"stelhex1","stelhex2","stelhex5","stelhex6" -- stelhex3 stelhex4+    ,"stelpd1","stelpd1s"+    ,"stelpent1","stelpent1s"+    ,"steltet1","steltet1s","steltet2"+    ,"steltri1","steltri2"+    ,"tritriad14"     ,"wilson1","wilson2","wilson3","wilson5","wilson7","wilson11"     ,"wilson7_2","wilson7_3","wilson7_4"     ,"wilson_17","wilson_31","wilson_41"
Music/Theory/Tuning/Scala/Mode.hs view
@@ -1,4 +1,15 @@--- | Parser for the @modename.par@ file.+{- | Parser for the @modename.par@ file.++The terminology here is:++- a mode is a subset of the notes of a tuning system (which in scala is called a scale)++- the length (or degree) of the mode is the number of tones in the mode++- the universe (or scale) of the mode is the number of tones in the+  tuning system (or scale) the mode is a subset of++-} module Music.Theory.Tuning.Scala.Mode where  import Data.Char {- base -}@@ -9,29 +20,50 @@ 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)+-- | (mode-start-degree,mode-intervals,mode-description)+type Mode = (Int,[Int],String) -mode_starting_degree :: MODE -> Int+-- | Starting degree of mode in underlying scale.  If non-zero the+-- mode will not lie within an ordinary octave of the tuning.+mode_starting_degree :: Mode -> Int mode_starting_degree (d,_,_) = d -mode_intervals :: MODE -> [Int]+-- | Intervals (in steps) between adjacent elements of the mode.+mode_intervals :: Mode -> [Int] mode_intervals (_,i,_) = i -mode_description :: MODE -> String+-- | Interval set of mode (ie. 'nub' of 'sort' of 'mode_intervals')+mode_iset :: Mode -> [Int]+mode_iset = nub . sort . mode_intervals++-- | Histogram ('List.histogram') of 'mode_intervals'+mode_histogram :: Mode -> [(Int, Int)]+mode_histogram = List.histogram . mode_intervals++-- | The text description of the mode, ordinarily a comma separated list of names.+mode_description :: Mode -> String mode_description (_,_,d) = d -mode_degree :: MODE -> Int-mode_degree = sum . mode_intervals+-- | 'length' (or degree) of 'mode_intervals' (ie. number of notes in mode)+mode_length :: Mode -> Int+mode_length = length . mode_intervals --- | (mode-count,_,mode-list)-type MODENAM = (Int,Int,[MODE])+-- | 'sum' of 'mode_intervals' (ie. number of notes in tuning system)+mode_univ :: Mode -> Int+mode_univ = sum . mode_intervals -modenam_modes :: MODENAM -> [MODE]+-- | 'List.dx_d' of 'mode_intervals'.  This seqence includes the octave.+mode_degree_seq :: Mode -> [Int]+mode_degree_seq = List.dx_d 0 . mode_intervals++-- | (mode-count,mode-length-maxima,mode-list)+type ModeNam = (Int,Int,[Mode])++modenam_modes :: ModeNam -> [Mode] modenam_modes (_,_,m) = m  -- | Search for mode by interval list.-modenam_search_seq :: MODENAM -> [Int] -> [MODE]+modenam_search_seq :: ModeNam -> [Int] -> [Mode] modenam_search_seq (_,_,m) x = filter ((== x) . mode_intervals) m  -- | Expect /one/ result.@@ -45,23 +77,49 @@ -- > sq [1,2,1,2,1,2,1,2] -- > sq [2,1,2,1,2,1,2,1] -- > sq (replicate 12 1)-modenam_search_seq1 :: MODENAM -> [Int] -> Maybe MODE+modenam_search_seq1 :: ModeNam -> [Int] -> Maybe Mode modenam_search_seq1 mn = List.unlist1 . modenam_search_seq mn  -- | Search for mode by description text. -- -- > map (modenam_search_description mn) ["Messiaen","Xenakis","Raga"]-modenam_search_description :: MODENAM -> String -> [MODE]+modenam_search_description :: ModeNam -> String -> [Mode] modenam_search_description (_,_,m) x = filter (isInfixOf x . mode_description) m --- | Pretty printer.-mode_stat :: MODE -> [String]-mode_stat (d,i,s) =-    ["mode-start-degree : " ++ show d-    ,"mode-intervals    : " ++ intercalate "," (map show i)-    ,"mode-degree       : " ++ show (sum i)-    ,"mode-description  : " ++ s]+-- | Is /p/ an element of the set of rotations of /q/.+mode_rot_eqv :: Mode -> Mode -> Bool+mode_rot_eqv p q =+  (mode_length p == mode_length q) &&+  (mode_univ p == mode_univ q) &&+  (mode_intervals p `elem` List.rotations (mode_intervals q)) +{- | Pretty printer.++> mn <- load_modenam++> let r = filter ((/=) 0 . mode_starting_degree) (modenam_modes mn) -- non-zero starting degrees+> let r = filter ((== [(1,2),(2,5)]) . mode_histogram) (modenam_modes mn) -- 2×1 and 5×2+> let r = filter ((== 22) . mode_univ) (modenam_search_description mn "Raga") -- raga of 22 shruti univ++> [(p,q) | p <- r, q <- r, p < q, mode_rot_eqv p q] -- rotationally equivalent elements of r++> length r+> putStrLn $ unlines $ intercalate ["\n"] $ map mode_stat r+-}+mode_stat :: Mode -> [String]+mode_stat m =+  let hst = mode_histogram m+      comma_map f = intercalate "," . map f+  in ["mode-start-degree : " ++ show (mode_starting_degree m)+     ,"mode-intervals    : " ++ comma_map show (mode_intervals m)+     ,"mode-description  : " ++ mode_description m+     ,"mode-length       : " ++ show (mode_length m)+     ,"mode-univ         : " ++ show (mode_univ m)+     ,"mode-interval-set : " ++ intercalate "," (map show (mode_iset m))+     ,"mode-histogram    : " ++ intercalate "," (map (\(e,n) -> concat [show n,"×",show e]) hst)+     ,"mode-degree-seq   : " ++ comma_map show (mode_degree_seq m)+     ]+ -- * Parser  -- | Bracketed integers are a non-implicit starting degree.@@ -80,12 +138,12 @@ is_integer :: String -> Bool is_integer = all isDigit -parse_modenam_entry :: [String] -> MODE+parse_modenam_entry :: [String] -> Mode parse_modenam_entry 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)+    let (n,c) = span (Function.predicate_or is_non_implicit_degree is_integer) w+    in case non_implicit_degree (n !! 0) of+         Nothing -> (0,map read n,unwords c)+         Just d -> (d,map read (tail n),unwords c)  -- | Lines ending with @\@ continue to next line. join_long_lines :: [String] -> [String]@@ -97,7 +155,7 @@       _ -> l  -- | Parse joined non-comment lines of modenam file.-parse_modenam :: [String] -> MODENAM+parse_modenam :: [String] -> ModeNam parse_modenam l =     case l of       n_str:x_str:m_str ->@@ -107,14 +165,15 @@         in if n == length m then (n,x,m) else error "parse_modenam"       _ -> error "parse_modenam" --- * IO+-- * Io --- | 'parse_modenam' of 'Scala.load_dist_file' of @modenam.par@.------ > mn <- load_modenam--- > let (n,x,m) = mn--- > n == 2933 && x == 15 && length m == n -- Scala 2.42p-load_modenam :: IO MODENAM+{- | 'parse_modenam' of 'Scala.load_dist_file' of @modenam.par@.++> mn <- load_modenam+> let (n,x,m) = mn+> (n, x, length m) == (3087,15,3087) -- Scala 2.64p+-}+load_modenam :: IO ModeNam load_modenam = do   l <- Scala.load_dist_file_ln "modenam.par"   return (parse_modenam (Scala.filter_comments (join_long_lines l)))
Music/Theory/Tuning/Sethares_1994.hs view
@@ -1,16 +1,26 @@ -- | William A. Sethares. -- "Adaptive Tunings for Musical Scales". -- /Journal of the Acoustical Society of America/, 96(1), July 1994.------ <http://sethares.engr.wisc.edu/consemi.html> module Music.Theory.Tuning.Sethares_1994 where -import qualified Music.Theory.Tuning as T+import Data.Maybe {- base -} --- > import Sound.SC3.Plot--- > plotTable1 (map (\f -> d (220,1) (f,1)) [220 .. 440])-d :: (Floating n, Ord n) => (n,n) -> (n,n) -> n-d (f1,v1) (f2,v2) =+import qualified Music.Theory.Tuning as T {- hmt -}++{- | Plomp-Levelt consonance curve.++R. Plomp and W. J. M. Levelt,+"Tonal Consonance and Critical Bandwidth,"+Journal of the Acoustical Society of America.38, 548-560 (1965).++"Relating Tuning and Timbre" <http://sethares.engr.wisc.edu/consemi.html>+MATLAB: <https://sethares.engr.wisc.edu/comprog.html>++> import Sound.SC3.Plot {- hsc3-plot -}+> plot_p1_ln [map (\f -> pl_dissonance (220,1) (f,1)) [220 .. 440]]+-}+pl_dissonance :: (Floating n, Ord n) => (n,n) -> (n,n) -> n+pl_dissonance (f1,v1) (f2,v2) =     let d_star = 0.24         s1 = 0.0207         s2 = 18.96@@ -24,16 +34,52 @@         e2 = c2 * exp (a2 * s * f_dif)     in v1 * v2 * (e1 + e2) --- > plotTable fig_1-fig_1 :: (Floating n,Enum n,Ord n) => [[n]]-fig_1 =+-- | Sum of 'pl_dissonance' for all p in s1 and all q in s2.+pl_dissonance_h :: (Floating n, Ord n) => [(n,n)] -> [(n,n)] -> n+pl_dissonance_h s1 s2 = sum [pl_dissonance p q | p <- s1, q <- s2]++-- | Return local minima of sequence with index.+local_minima :: Ord t => [t] -> [(Int,t)]+local_minima =+  let f (ix,i,j,k) = if j <= i && j <= k then Just (ix,j) else Nothing+      triples ix l = case l of+                       i:j:k:_ -> (ix,i,j,k) : triples (ix + 1) (tail l)+                       _ -> []+  in mapMaybe f . triples 1++-- | William A. Sethares "Adaptive Tunings for Musical Scales".+--+-- > plot_p1_ln atms_fig_1+atms_fig_1 :: (Floating n,Enum n,Ord n) => [[n]]+atms_fig_1 =     let f0 = [125,250,500,1000,2000]         r_seq = map T.cents_to_fratio [0 .. 1200]-    in map (\f -> map (\r -> d (f,1) (f * r,1)) r_seq) f0+    in map (\f -> map (\r -> pl_dissonance (f,1) (f * r,1)) r_seq) f0 --- > let a_seq = take 7 (iterate (* 0.88) 1.0)--- > let gen f0 = zipWith (\r a -> (f0 * r,a)) [1 .. 7] a_seq--- > let r_seq = map T.cents_to_ratio [0,1 .. 1200]--- > plotTable1 (let f0 = 880 in map (\r -> d_h (gen f0) (gen (f0 * r))) r_seq)-d_h :: (Floating n, Ord n) => [(n,n)] -> [(n,n)] -> n-d_h s1 s2 = sum [d p q | p <- s1, q <- s2]+-- > plot_p1_ln [atms_fig_2 880]+-- > map fst (local_minima (atms_fig_2 880)) == [204,231,267,316,386,435,498,583,702,814,884,969,1018]+atms_fig_2 :: (Ord t, Floating t, Enum t) => t -> [t]+atms_fig_2 f0 =+  let gen fq = map (\r -> (fq * r,1)) [1 .. 9]+      r_seq = map T.cents_to_fratio [0,1 .. 1200]+  in map (\r -> pl_dissonance_h (gen f0) (gen (f0 * r))) r_seq++-- > Sound.SC3.Plot.plot_p1_ln [atms_fig_3 880]+-- > map fst (local_minima (atms_fig_3 880)) == [267,400,533,667,800,933,1043]+atms_fig_3 :: (Ord t, Floating t, Enum t) => t -> [t]+atms_fig_3 f0 =+  let b = 2 ** (1/9)+      gen fq = map (\r -> (fq * r,1)) (1 : map (b **) [9,14,18,21,25,27,30])+      r_seq = map T.cents_to_fratio [0,1 .. 1200]+  in map (\r -> pl_dissonance_h (gen f0) (gen (f0 * r))) r_seq++-- | "Relating Tuning and Timbre" <http://sethares.engr.wisc.edu/consemi.html>+--+-- > plot_p1_ln [rtt_fig_2 880]+-- > map fst (local_minima (rtt_fig_2 880)) == [267,316,386,498,582,702,884,969]+rtt_fig_2 :: (Ord t, Floating t, Enum t) => t -> [t]+rtt_fig_2 f0 =+  let a_seq = take 7 (iterate (* 0.88) 1.0)+      gen fq = zipWith (\r a -> (fq * r,a)) [1 .. 7] a_seq+      r_seq = map T.cents_to_fratio [0,1 .. 1200]+  in map (\r -> pl_dissonance_h (gen f0) (gen (f0 * r))) r_seq
Music/Theory/Tuning/Syntonic.hs view
@@ -3,11 +3,18 @@  import Data.List {- base -} -import Music.Theory.Tuning {- hmt -}-import Music.Theory.Tuning.Type {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.Type as T {- hmt -} --- | Construct an isomorphic layout of /r/ rows and /c/ columns with--- an upper left value of /(i,j)/.+{- | Construct an isomorphic layout of /r/ rows and /c/ columns with an upper left value of /(i,j)/.++> r = [[(0,0),(-1,2),(-2,4)],[(-1,1),(-2,3),(-3,5)],[(-2,2),(-3,4),(-4,6)]]+> mk_isomorphic_layout 3 3 (0,0) == r+> map (map fst) r == [[0,-1,-2],[-1,-2,-3],[-2,-3,-4]]+> map (map snd) r == [[0,2,4],[1,3,5],[2,4,6]]+> map (map fst) r == map (map fst) (transpose r)+> map (map snd) (transpose r) == [[0,1,2],[2,3,4],[4,5,6]]+-} mk_isomorphic_layout :: Integral a => a -> a -> (a,a) -> [[(a,a)]] mk_isomorphic_layout n_row n_col top_left =     let (a,b) `plus` (c,d) = (a+c,b+d)@@ -22,9 +29,9 @@ -- > [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout minimal_isomorphic_note_layout :: [[(Int,Int)]] minimal_isomorphic_note_layout =-    [[(3,-4),(2,-2),(1,0),(0,2),(-1,4)]-       ,[(2,-3),(1,-1),(0,1),(-1,3)]-    ,[(2,-4),(1,-2),(0,0),(-1,2),(-2,4)]]+  [[(3,-4),(2,-2),(1,0),(0,2),(-1,4)]+  ,[(2,-3),(1,-1),(0,1),(-1,3)]+  ,[(2,-4),(1,-2),(0,0),(-1,2),(-2,4)]]  -- | Make a rank two regular temperament from a list of /(i,j)/ -- positions by applying the scalars /a/ and /b/.@@ -35,7 +42,7 @@ -- rows and @7@ columns starting at @(3,-4)@ and a -- 'rank_two_regular_temperament' with /a/ of @1200@ and indicated -- /b/.-mk_syntonic_tuning :: Int -> [Cents]+mk_syntonic_tuning :: Int -> [T.Cents] mk_syntonic_tuning b =   let l = mk_isomorphic_layout 5 7 (3,-4)       t = map (rank_two_regular_temperament 1200 b) l@@ -48,8 +55,8 @@ > 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)) Nothing+syntonic_697 :: T.Tuning+syntonic_697 = T.Tuning (Right (mk_syntonic_tuning 697)) Nothing  -- | 'mk_syntonic_tuning' of @702@. --@@ -57,5 +64,5 @@ -- -- > let c = [0,24,114,204,294,318,408,498,522,612,702,792,816,906,996,1020,1110] -- > tn_cents_i syntonic_702 == c-syntonic_702 :: Tuning-syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) Nothing+syntonic_702 :: T.Tuning+syntonic_702 = T.Tuning (Right (mk_syntonic_tuning 702)) Nothing
Music/Theory/Tuning/Type.hs view
@@ -33,7 +33,7 @@  -- | Tuning octave, defaulting to 2:1. tn_octave_def :: Tuning -> Either Rational T.Cents-tn_octave_def = maybe (Left 2) id . tn_octave+tn_octave_def = fromMaybe (Left 2) . tn_octave  -- | Tuning octave in cents. tn_octave_cents :: Tuning -> T.Cents@@ -110,7 +110,7 @@ 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)+    in o_ratio * (tn_approximate_ratios t !! pc)  -- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents' -- of 'Tuning'.
Music/Theory/Tuning/Wilson.hs view
@@ -4,29 +4,31 @@ import Control.Monad {- base -} import Data.List {- base -} import Data.Maybe {- base -}+import Data.Ord {- 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 -}+import qualified Safe {- safe -} --- * GEOM (SEE "Data.CG.Minus.Plain")+import qualified Music.Theory.Array.Text as Text {- hmt-base -}+import qualified Music.Theory.Function as Function {- hmt-base -}+import qualified Music.Theory.Graph.Type as Graph {- hmt-base -}+import qualified Music.Theory.List as List {- hmt-base -}+import qualified Music.Theory.Math as Math {- hmt-base -}+import qualified Music.Theory.Math.Convert as Convert {- hmt-base -}+import qualified Music.Theory.Show as Show {- hmt-base -}+import qualified Music.Theory.Tuple as Tuple {- hmt-base -} +import qualified Music.Theory.Graph.Dot as Dot {- hmt -}+import qualified Music.Theory.Interval.Barlow_1987 as Barlow {- hmt -}+import qualified Music.Theory.Math.Oeis as OEIS {- hmt -}+import qualified Music.Theory.Math.Prime as Prime {- hmt -}+import qualified Music.Theory.Set.List as Set {- hmt -}+import qualified Music.Theory.Tuning as Tuning {- hmt -}+import qualified Music.Theory.Tuning.Scala as Scala {- 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)@@ -39,7 +41,7 @@ v2_scale :: Num n => n -> V2 n -> V2 n v2_scale n = v2_map (* n) --- * PT SET+-- * Pt Set  {- | Normalise set of points to lie in (-1,-1) - (1,1), scaling symetrically about (0,0) @@ -47,84 +49,92 @@ > 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+pt_set_normalise_sym x =+  let z = maximum (map (uncurry max . Function.bimap1 abs) x)+  in map (v2_scale (recip z)) x --- * LATTICE CO-ORD+-- * Lattice Design  -- | /k/-unit co-ordinates for /k/-lattice.-type LC n = [V2 n]+type Lattice_Design n = (Int,[V2 n])  -- | Erv Wilson standard lattice, unit co-ordinates for 5-dimensions, ie. [3,5,7,11,13] -- -- <http://anaphoria.com/wilsontreasure.html>-ew_lc_std :: Num n => LC n-ew_lc_std = [(20,0),(0,20),(4,3),(-3,4),(-1,2)]+ew_lc_std :: Num n => Lattice_Design n+ew_lc_std = (5,[(20,0),(0,20),(4,3),(-3,4),(-1,2)])  -- | Kraig Grady standard lattice, unit co-ordinates for 5-dimensions, ie. [3,5,7,11,13] -- -- <http://anaphoria.com/wilsontreasure.html>-kg_lc_std :: Num n => LC n-kg_lc_std = [(40,0),(0,40),(13,11),(-14,18),(-8,4)]+kg_lc_std :: Num n => Lattice_Design n+kg_lc_std = (5,[(40,0),(0,40),(13,11),(-14,18),(-8,4)]) --- | Erv Wilson tetradic lattice, used especially when working with hexanies or 7 limit tunings+-- | Erv Wilson tetradic lattice (3-lattice), used especially when working with hexanies or 7 limit tunings -- -- <http://anaphoria.com/wilsontreasure.html>-ew_lc_tetradic :: Num n => LC n-ew_lc_tetradic = [(-4,-2),(6,1),(5,-2)]---- | Resolve POS against LC to V2-lc_pos_to_pt :: (Fractional n, Ord n) => LC n -> POS -> V2 n-lc_pos_to_pt lc x = v2_sum (zipWith (v2_scale . fromIntegral) x (pt_set_normalise_sym lc))+ew_lc_tetradic :: Num n => Lattice_Design n+ew_lc_tetradic = (3,[(-4,-2),(6,1),(5,-2)]) --- * LAT+-- * Lattice_Factors  -- | A discrete /k/-lattice is described by a sequence of /k/-factors.---   LAT values are ordinarily though not necessarily primes.-type LAT = [Integer]+--   Values are ordinarily though not necessarily primes beginning at three.+type Lattice_Factors i = (Int,[i])  -- | Positions in a /k/-lattice are given as a /k/-list of steps.-type POS = [Int]+type Lattice_Position = (Int,[Int]) --- | White-space pretty printer for POS.+-- | Delete entry at index.+lc_pos_del :: Int -> Lattice_Position -> Lattice_Position+lc_pos_del ix (k,x) = (k - 1,List.remove_ix ix x)++-- | Resolve Lattice_Position against Lattice_Design to V2+lc_pos_to_pt :: (Fractional n, Ord n) => Lattice_Design n -> Lattice_Position -> V2 n+lc_pos_to_pt (_,lc) (_,x) = v2_sum (zipWith (v2_scale . fromIntegral) x (pt_set_normalise_sym lc))++-- | White-space pretty printer for Lattice_Position. ----- > 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+-- > pos_pp_ws (3,[0,-2,1]) == "  0 -2  1"+pos_pp_ws :: Lattice_Position -> String+pos_pp_ws = let f x = printf "%3d" x in concatMap f . snd --- | Given LAT [X,Y,Z..] and POS [x,y,z..], calculate the indicated ratio.+-- | Given Lattice_Factors [X,Y,Z..] and Lattice_Position [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 =+-- > lat_res (2,[3,5]) (2,[-5,2]) == (5 * 5) / (3 * 3 * 3 * 3 * 3)+lat_res :: Integral i => Lattice_Factors i -> Lattice_Position -> Ratio i+lat_res (_,p) (_,q) =   let f i j = case compare j 0 of-                GT -> (i ^ T.int_to_integer j) % 1+                GT -> (i ^ Convert.int_to_integer j) % 1                 EQ -> 1-                LT -> 1 % (i ^ abs (T.int_to_integer j))+                LT -> 1 % (i ^ abs (Convert.int_to_integer j))   in product (zipWith f p q) --- * RAT (n,d)+-- * Rat (n,d)  -- | Ratio given as (/n/,/d/)-type RAT = (Integer,Integer)+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+rat_rem_oct :: Rat -> Rat+rat_rem_oct = Function.bimap1 (product . filter (/= 2)) . Prime.rat_prime_factors --- | Lift 'RAT' function to 'Rational'.-rat_lift_1 :: (RAT -> RAT) -> Rational -> Rational-rat_lift_1 f = uncurry (%) . f . T.rational_nd+-- | Lift 'Rat' function to 'Rational'.+rat_lift_1 :: (Rat -> Rat) -> Rational -> Rational+rat_lift_1 f = uncurry (%) . f . Math.rational_nd -rat_to_ratio :: RAT -> Rational+-- | Convert 'Rat' to 'Rational'+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 :: Rat -> Rat -> Rat rat_mediant (n1,d1) (n2,d2) = (n1 + n2,d1 + d2) -rat_pp :: RAT -> String+-- | Rat written as n/d+rat_pp :: Rat -> String rat_pp (n,d) = concat [show n,"/",show d]  -- * Rational@@ -143,63 +153,84 @@ -- -- > r_seq_limit [1] == 1 r_seq_limit :: [Rational] -> Integer-r_seq_limit = maximum . map T.rational_prime_limit+r_seq_limit = maximum . map Prime.rational_prime_limit +-- | Find factors of set of ratios, ie. the union of all factor in both numerator & denominator.+--+-- > r_seq_factors [1/3,5/7,9/8,13,27,31] == [2,3,5,7,13,31]+r_seq_factors :: [Rational] -> [Integer]+r_seq_factors = nub . sort . concatMap (uncurry (++) . Prime.rational_prime_factors)+ -- * 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+-- | Vector of prime-factors up to /limit/.+--+-- > map (rat_fact_lm 11) [3,5,7,2/11] == [(5,[0,1,0,0,0]),(5,[0,0,1,0,0]),(5,[0,0,0,1,0]),(5,[1,0,0,0,-1])]+rat_fact_lm :: Integer -> Rational -> Lattice_Position+rat_fact_lm lm =+  let k = fromMaybe 1 (Prime.prime_k lm) + 1+  in (\c -> (k,c)) .+     Prime.rat_prime_factors_t k .+     Math.rational_nd -tbl_txt :: Integer -> [Rational] -> [[String]]-tbl_txt lm_z rs =+tbl_txt :: Bool -> Integer -> [Rational] -> [[String]]+tbl_txt del 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]+      scl = map ((if del then lc_pos_del 0 else id) . rat_fact_lm lm) rs+      cs = map (Tuning.ratio_to_cents . Tuning.fold_ratio_to_octave_err) rs+      hs = map (Barlow.harmonicity_r Barlow.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]+                      ,Show.ratio_pp r+                      ,Show.real_pp 2 c+                      ,Show.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+-- > tbl_wr False [1,7/6,5/4,4/3,3/2]+-- > tbl_wr True [1,3,1/5,15/31]+tbl_wr :: Bool -> [Rational] -> IO ()+tbl_wr del = putStr . unlines . Text.table_pp (False,True,False," ",False) . tbl_txt del 31  -- * Graph --- | (maybe-lc,gr-attr,vertex-pp)-type EW_GR_OPT = (Maybe (LC Rational),[T.DOT_META_ATTR],Rational -> String)+-- | (maybe (maybe lattice-design, maybe primes),gr-attr,vertex-pp)+type Ew_Gr_Opt = (Maybe (Lattice_Design Rational,Maybe [Integer]),[Dot.Dot_Meta_Attr],Rational -> String) -ew_gr_opt_pos :: EW_GR_OPT -> Bool+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 =+-- > map (ew_gr_r_pos ew_lc_std (Just [3,5,31])) [3,5,31]+ew_gr_r_pos :: Lattice_Design Rational -> Maybe [Integer] -> Rational -> Dot.Dot_Attr+ew_gr_r_pos (k,lc) primes_l =   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+  in Dot.node_pos_attr .+     f 160 .+     lc_pos_to_pt (k,lc) .+     (\c -> (k,c)) .+     -- this is a little subtle, tail removes the '2' slot from rational_prime_factors_t+     maybe (tail . Prime.rational_prime_factors_t (k + 1)) Prime.rational_prime_factors_c primes_l -ew_gr_udot :: EW_GR_OPT -> T.LBL Rational () -> [String]+-- | 'Dot.lbl_to_udot' add position attribute if a 'Lattice_Design' is given.+ew_gr_udot :: Ew_Gr_Opt -> Graph.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+                  Just (lc,primes_l) -> ("neato",Just . ew_gr_r_pos lc primes_l)+  in Dot.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)]-     ,\_ -> [])+     (\(_,v) -> List.mcons (p_f v) [("label",v_pp v)]+     ,const []) -ew_gr_udot_wr :: EW_GR_OPT -> FilePath -> T.LBL Rational () -> IO ()+-- | 'writeFile' of 'ew_gr_udot'+ew_gr_udot_wr :: Ew_Gr_Opt -> FilePath -> Graph.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 :: Ew_Gr_Opt -> FilePath -> Graph.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"))+  void (Dot.dot_to_svg (if ew_gr_opt_pos opt then ["-n"] else []) fn) --- * ZIG-ZAG+-- * 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)@@ -223,7 +254,7 @@ zz_seq :: (Eq n, Num n) => [Int] -> [[(n, n)]] zz_seq k_seq = zz_recur k_seq [(0,1),(1,1)] --- * MOS+-- * Mos  -- > gen_coprime 12 == [1,5] -- > gen_coprime 49 == [1..24] \\ [7,14,21]@@ -247,7 +278,7 @@ 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+  in if Tuple.t2_sum y == 3 then [x,y] else x : mos_unfold y  mos_verify :: Integral a => a -> a -> Bool mos_verify p g =@@ -265,7 +296,7 @@ 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+      ((i0,j0), r) = List.headTail (mos p g)   in recur_f r [i0,j0]  mos_cell_pp :: (Integral i,Show i) => i -> String@@ -281,7 +312,7 @@ mos_tbl_wr :: (Integral i,Show i) => [[i]] -> IO () mos_tbl_wr = putStrLn . unlines . mos_tbl_pp --- * MOS/LOG+-- * 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))@@ -294,29 +325,29 @@ mos_log_kseq :: Double -> [Int] mos_log_kseq = map fst . mos_log --- * STERN-BROCOT TREE+-- * Stern-Brocot Tree  data SBT_DIV = NIL | LHS | RHS deriving (Show)-type SBT_NODE = (SBT_DIV,RAT,RAT,RAT)+type Sbt_Node = (SBT_DIV,Rat,Rat,Rat) -sbt_step :: SBT_NODE -> [SBT_NODE]+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 :: Sbt_Node sbt_root = (NIL,(0,1),(1,1),(1,0)) -sbt_half :: SBT_NODE+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 :: Sbt_Node -> [[Sbt_Node]] sbt_from = iterate (concatMap sbt_step) . return -sbt_k_from :: Int -> SBT_NODE -> [[SBT_NODE]]+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 :: 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@@ -324,153 +355,155 @@        LHS -> edge_pp r m        RHS -> edge_pp l m -sbt_node_elem :: SBT_NODE -> [RAT]+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 :: [Sbt_Node] -> [String] sbt_dot n =   let e = map sbt_node_to_edge n   in concat [["graph {","node [shape=plain]"],e,["}"]] --- * M-GEN+-- * M-Gen  (^.) :: Rational -> Int -> Rational (^.) = (^)  r_normalise :: [Rational] -> [Rational]-r_normalise = nub . sortOn T.fold_ratio_to_octave_err+r_normalise = nub . sortOn Tuning.fold_ratio_to_octave_err  -- | (ratio,multiplier,steps)-type M_GEN = (Rational,Rational,Int)+type M_Gen = (Rational,Rational,Int) -m_gen_unfold :: M_GEN -> [Rational]+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 :: [M_Gen] -> [Rational] m_gen_to_r = r_normalise . concatMap m_gen_unfold --- * M3-GEN+-- * M3-Gen  -- | (ratio,M3-steps)-type M3_GEN = (Rational,Int)+type M3_Gen = (Rational,Int) -m3_to_m :: M3_GEN -> M_GEN+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 :: M3_Gen -> [Rational] m3_gen_unfold = m_gen_unfold . m3_to_m -m3_gen_to_r :: [M3_GEN] -> [Rational]+m3_gen_to_r :: [M3_Gen] -> [Rational] m3_gen_to_r = r_normalise . concatMap m3_gen_unfold --- * SCALA+-- * Scala -r_to_scale :: String -> String -> [Rational] -> T.Scale+r_to_scale :: String -> String -> [Rational] -> Scala.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')+  let r' = map Tuning.fold_ratio_to_octave_err (tail r) ++ [2]+  in if r !! 0 /= 1 || not (List.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 :: [Rational] -> [Scala.Scale] -> [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]))+      r' = map Tuning.fold_ratio_to_octave_err r+  in if head r' /= 1+     then error "ew_scl_find_r?: r'0 /= 1"+     else map Scala.scale_name . Scala.scl_find_ji set_eq (r' ++ [2])  -- * <http://anaphoria.com/1-3-5-7-9Genus.pdf> -ew_1357_3_gen :: [M3_GEN]+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}+{- | P.3 7-limit {Scala=nil} -> ew_scl_find_r (1 : ew_1357_3_r)+> db <- Scala.scl_load_db+> ew_scl_find_r (1 : ew_1357_3_r) db -} 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 :: Scala.Scale ew_1357_3_scl = r_to_scale "ew_1357_3" "EW, 1-3-5-7-9Genus.pdf, P.3" (1 : ew_1357_3_r)  -- * <http://anaphoria.com/earlylattices12.pdf> -{- | P.7 11-limit {SCALA=NIL}+{- | P.7 11-limit {Scala=nil} -> ew_scl_find_r ew_el12_7_r+> ew_scl_find_r ew_el12_7_r db -} 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 :: Scala.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}+{- | P.9 7-limit {Scala=wilson_class} -> ew_scl_find_r ew_el12_9_r+> ew_scl_find_r ew_el12_9_r db -} 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 :: Scala.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}+{- | P.12 11-limit {Scala=nil} -> ew_scl_find_r ew_el12_12_r+> ew_scl_find_r ew_el12_12_r db -} 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 :: Scala.Scale ew_el12_12_scl = r_to_scale "ew_el12_12" "EW, earlylattices12.pdf, P.12" ew_el12_12_r  -- * <http://anaphoria.com/earlylattices22.pdf> -{- | P.2 11-limit {SCALA=wilson_l4}+{- | P.2 11-limit {Scala=wilson_l4} -> ew_scl_find_r ew_el22_2_r+> ew_scl_find_r ew_el22_2_r db -} 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}+{- | P.3 11-limit {Scala=wilson_l5} -> ew_scl_find_r ew_el22_3_r+> ew_scl_find_r ew_el22_3_r db -} 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}+{- | P.4 11-limit {Scala=wilson_l3} -> ew_scl_find_r ew_el22_4_r+> ew_scl_find_r ew_el22_4_r db -} 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}+{- | P.5 11-limit {Scala=wilson_l1} -> ew_scl_find_r ew_el22_5_r+> ew_scl_find_r ew_el22_5_r db -} 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}+{- | P.6 11-limit {Scala=wilson_l2} -> ew_scl_find_r ew_el22_6_r+> ew_scl_find_r ew_el22_6_r db -} ew_el22_6_r :: [Rational] ew_el22_6_r =@@ -483,26 +516,26 @@ 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 :: [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}+{- | 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_scl_find_r ew_diamond_12_r db -- 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}+{- | 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_scl_find_r ew_diamond_13_r db -- novaro15 -} ew_diamond_13_r :: [Rational] ew_diamond_13_r = ew_diamond_mk [1,3,5,7,9,11,13,15]@@ -518,38 +551,38 @@ 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))+  in (take 5 i,take 5 (List.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))+  in (take 8 (List.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))+  in (take 13 (List.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}+{- | P.12 {Scala=nil}  22-tone 23-limit Evangalina tuning (2001) -> ew_scl_find_r ew_hel_12_r+> ew_scl_find_r ew_hel_12_r db -} 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 :: Scala.Scale ew_hel_12_scl = r_to_scale "ew_hel_12" "EW, hel.pdf, P.12" ew_hel_12_r  -- * <http://anaphoria.com/HexanyStellatesExpansions.pdf>@@ -558,7 +591,7 @@ 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))+  in map (sortOn (Down . length)) (filter f (Set.partitions x))  -- > she_div_r [1,3,5,7] == [105,35/3,21/5,15/7] she_div_r :: [Rational] -> [Rational]@@ -571,16 +604,16 @@  -- > 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_mul_r r = [x * y | x <- r,y <- r,x <= y] -{- | she = Stellate Hexany Expansions, P.10 {SCALA=stelhex1,stelhex2,stelhex5,stelhex6}+{- | 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+> mapM (flip ew_scl_find_r db . 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]) db -- NIL -} she :: [Rational] -> [Rational]-she r = nub (sort (map T.fold_ratio_to_octave_err (she_mul_r r ++ she_div_r r)))+she r = nub (sort (map Tuning.fold_ratio_to_octave_err (she_mul_r r ++ she_div_r r)))  -- * <http://anaphoria.com/meru.pdf> @@ -593,7 +626,7 @@  meru :: Num n => [[n]] meru =-  let f xs = zipWith (+) ([0] ++ xs) (xs ++ [0])+  let f xs = zipWith (+) (0 : xs) (xs ++ [0])   in iterate f [1]  -- > meru_k 13@@ -602,26 +635,26 @@  -- > 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))+meru_1 k = zipWith (flip (Safe.atDef 0)) [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_1_direct = tail OEIS.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)+meru_2 k = zipWith (flip (Safe.atDef 0)) [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_2_direct = OEIS.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+  let f t = zipWith (flip (Safe.atDef 0)) [0,2..] t       t0 = reverse (meru_k k)       t1 = map tail t0   in [f t0,f t1]@@ -632,20 +665,20 @@  -- > 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+meru_3_direct = drop 3 OEIS.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)+meru_4 k = zipWith (flip (Safe.atDef 0)) [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+meru_4_direct = tail OEIS.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+  let f t = zipWith (flip (Safe.atDef 0)) [0,3..] t       t0 = reverse (meru_k k)   in map (\n -> f (map (drop n) t0)) [0 .. 2] @@ -655,25 +688,25 @@  -- > take 39 meru_5_direct == map sum (meru_5_seq 13) meru_5_direct :: Num n => [n]-meru_5_direct = T.a017817+meru_5_direct = OEIS.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)+meru_6 k = zipWith (flip (Safe.atDef 0)) [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+meru_6_direct = OEIS.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+meru_7_direct = OEIS.a001687  -- * <http://anaphoria.com/mos.pdf> -{- | P.13, tanabe {SCALA=chin_7}+{- | P.13, tanabe {Scala=chin_7} -> ew_scl_find_r ew_mos_13_tanabe_r+> ew_scl_find_r ew_mos_13_tanabe_r db -} ew_mos_13_tanabe_r :: [Rational] ew_mos_13_tanabe_r = [1,9/8,81/64,4/3,3/2,27/16,243/128]@@ -682,62 +715,62 @@  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+  let rem_oct x = if last x /= 2 then error "rem_oct?" else List.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+      r_to_i = List.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+      i = List.rotations i_0   in (i,map i_to_r i) -{- | P.1 {SCALA=NIL}+{- | P.1 {Scala=nil}  23-tone 7-limit (2004) -> ew_scl_find_r ew_novarotreediamond_1_r+> ew_scl_find_r ew_novarotreediamond_1_r db -} 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 :: Scala.Scale ew_novarotreediamond_1_scl = r_to_scale "ew_novarotreediamond_1" "EW, novavotreediamond.pdf, P.1" ew_novarotreediamond_1_r  -- * <http://anaphoria.com/Pelogflute.pdf> -{- | P.2 {SCALA=NIL}+{- | P.2 {Scala=nil}  9-tone Pelog cycle (1988) -> ew_scl_find_r ew_pelogFlute_2+> ew_scl_find_r ew_Pelogflute_2_r db -} 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 :: Scala.Scale ew_Pelogflute_2_scl = r_to_scale "ew_Pelogflute_2" "EW, Pelogflute.pdf, P.2" ew_Pelogflute_2_r   -- * <http://anaphoria.com/xen1.pdf>  -- | P.9, Fig. 3-xen1_fig3 :: (SBT_NODE,Int)+xen1_fig3 :: (Sbt_Node,Int) xen1_fig3 = ((NIL,(1,3),(2,5),(1,2)),5)  -- | P.9, Fig. 4-xen1_fig4 :: (SBT_NODE,Int)+xen1_fig4 :: (Sbt_Node,Int) xen1_fig4 = ((NIL,(2,5),(5,12),(3,7)),5)  -- * <http://anaphoria.com/xen3b.pdf> --- | P.3 Turkisk Baglama Scale {11-limit, SCALA=NIL}+-- | 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 :: Scala.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]@@ -751,10 +784,10 @@  {- | P.9 {SCALA 5=nil 7=ptolemy_idiat 12=nil 19=wilson2 31=wilson_31} -> mapM ew_scl_find_r xen3b_9_r+> mapM ew_scl_find_r xen3b_9_r db -} xen3b_9_r :: [[Rational]]-xen3b_9_r = map (T.drop_last . scanl (*) 1) xen3b_9_i+xen3b_9_r = map (List.drop_last . scanl (*) 1) xen3b_9_i  -- > map length xen3b_13_i == [5,7,12,17,22] xen3b_13_i :: [[Rational]]@@ -767,7 +800,7 @@  -- | 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+xen3b_13_r = map (List.drop_last . scanl (*) 1) xen3b_13_i  -- * <http://anaphoria.com/xen3bappendix.pdf> @@ -775,7 +808,7 @@  17,31,41 lattices from XEN3B (1975) -}-ew_xen3b_apx_gen :: [(Int,[M3_GEN])]+ew_xen3b_apx_gen :: [(Int,[M3_Gen])] ew_xen3b_apx_gen =   [(17,[(1/729,12)        ,(5/3,3)@@ -802,19 +835,19 @@  -- * <http://anaphoria.com/xen456.pdf> -ew_xen456_7_gen :: [M3_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}+{- P.7 {Scala=wilson1}  19-tone "A Scale for Scott" (1976) -> L.ew_find_scl_name ew_xen456_7_r -- wilson1+> ew_scl_find_r ew_xen456_7_r db -- 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 :: [M3_Gen] ew_xen456_9_gen =   [(1/(3^.3),4)   ,(1/(5*(3^.2)),3)@@ -823,68 +856,68 @@   ,(5/(11*3),4)   ,(7/11,2)] -{- | P.9 {SCALA=NIL}+{- | P.9 {Scala=nil ; Scala:Rot=wilson11}  19-tone scale for the Clavichord-19 (1976) -> ew_scl_find_r ew_xen456_9_r+> ew_scl_find_r ew_xen456_9_r db -> import qualified Music.Theory.List as T {- hmt -}-> T.scl_find_ji T.is_subset ew_xen456_9_r -- NIL+> import qualified Music.Theory.List as List {- hmt -}+> Scala.scl_find_ji List.is_subset ew_xen456_9_r db -- 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 :: Scala.Scale ew_xen456_9_scl = r_to_scale "ew_xen456_9" "EW, xen456.pdf, P.9" ew_xen456_9_r --- * GEMS+-- * Gems  {- | <http://wilsonarchives.blogspot.com/2010/10/scale-for-rod-poole.html> -13-limit 22-tone scale {SCALA=nil}+13-limit 22-tone scale {Scala=nil} -> ew_scl_find_r ew_poole_r+> ew_scl_find_r ew_poole_r db -} 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 :: Scala.Scale ew_poole_scl = r_to_scale "ew_poole" "EW, 2010/10/scale-for-rod-poole.html" ew_poole_r  {- | <http://wilsonarchives.blogspot.com/2014/05/an-11-limit-centaur-implied-in-wilson.html> -11-limit 17-tone scale {SCALA=wilcent17}+11-limit 17-tone scale {Scala=wilcent17} -> ew_scl_find_r ew_centaur17_r+> ew_scl_find_r ew_centaur17_r db -} ew_centaur17_r :: [Rational] ew_centaur17_r = [1,11/(3*7),11/5,3*3,7/3,11/(3*3),5,1/3,11,11/(3*5),3,11/7,11/(3*3*3),5/3,7,11/3,3*5]  {- | <http://wilsonarchives.blogspot.com/2018/03/an-unusual-22-tone-7-limit-tuning.html> -7-limit 22-tone scale {SCALA=nil}+7-limit 22-tone scale {Scala=nil} -> ew_scl_find_r ew_two_22_7_r+> ew_scl_find_r ew_two_22_7_r db -} 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]+  [1,9/35,1/15,35,9,7/3,3/5,315,245/3,21,27/5+  ,7/5,735,189,49,63/5,5/3,3/7,1/9,1/35,15,35/9] -ew_two_22_7_scl :: T.Scale+ew_two_22_7_scl :: Scala.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+-- * 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+> mapM_ (Scala.scale_wr_dir "/home/rohan/sw/hmt/data/scl/") ew_scl_db+> map Scala.scale_name ew_scl_db -}-ew_scl_db :: [T.Scale]+ew_scl_db :: [Scala.Scale] ew_scl_db =   [ew_1357_3_scl   ,ew_el12_7_scl
− Music/Theory/Tuple.hs 
@@ -1,369 +0,0 @@--- | Tuple functions.------ Uniform tuples have types 'T2', 'T3' etc. and functions names are--- prefixed @t2_@ etc.------ Heterogenous tuples (products) are prefixed @p2_@ etc.-module Music.Theory.Tuple where---- * P2 (2-product)--p2_swap :: (s,t) -> (t,s)-p2_swap (i,j) = (j,i)---- * T2 (2-tuple, regular)---- | Uniform two-tuple.-type T2 a = (a,a)--t2_from_list :: [t] -> T2 t-t2_from_list l = case l of {[p,q] -> (p,q);_ -> error "t2_from_list"}--t2_to_list :: T2 a -> [a]-t2_to_list (i,j) = [i,j]--t2_swap :: T2 t -> T2 t-t2_swap = p2_swap--t2_map :: (p -> q) -> T2 p -> T2 q-t2_map f (p,q) = (f p,f q)--t2_zipWith :: (p -> q -> r) -> T2 p -> T2 q -> T2 r-t2_zipWith f (p,q) (p',q') = (f p p',f q q')--t2_infix :: (a -> a -> b) -> T2 a -> b-t2_infix f (i,j) = i `f` j---- | Infix 'mappend'.------ > t2_join ([1,2],[3,4]) == [1,2,3,4]-t2_join :: Monoid m => T2 m -> m-t2_join = t2_infix mappend--t2_concat :: [T2 [a]] -> T2 [a]-t2_concat = t2_map mconcat . unzip--t2_sort :: Ord t => (t,t) -> (t,t)-t2_sort (p,q) = (min p q,max p q)---- | T2 variant of 'sum'-t2_sum :: Num n => (n,n) -> n-t2_sum (i,j) = i + j---- * P3 (3-product)---- | Left rotation.------ > p3_rotate_left (1,2,3) == (2,3,1)-p3_rotate_left :: (s,t,u) -> (t,u,s)-p3_rotate_left (i,j,k) = (j,k,i)--p3_fst :: (a,b,c) -> a-p3_fst (a,_,_) = a--p3_snd :: (a,b,c) -> b-p3_snd (_,b,_) = b--p3_third :: (a,b,c) -> c-p3_third (_,_,c) = c---- * T3 (3 triple, regular)--type T3 a = (a,a,a)--t3_from_list :: [t] -> T3 t-t3_from_list l = case l of {[p,q,r] -> (p,q,r);_ -> error "t3_from_list"}--t3_to_list :: T3 a -> [a]-t3_to_list (i,j,k) = [i,j,k]--t3_rotate_left :: T3 t -> T3 t-t3_rotate_left = p3_rotate_left--t3_fst :: T3 t -> t-t3_fst = p3_fst--t3_snd :: T3 t -> t-t3_snd = p3_snd--t3_third :: T3 t -> t-t3_third = p3_third--t3_map :: (p -> q) -> T3 p -> T3 q-t3_map f (p,q,r) = (f p,f q,f r)--t3_zipWith :: (p -> q -> r) -> T3 p -> T3 q -> T3 r-t3_zipWith f (p,q,r) (p',q',r') = (f p p',f q q',f r r')--t3_infix :: (a -> a -> a) -> T3 a -> a-t3_infix f (i,j,k) = (i `f` j) `f` k--t3_join :: T3 [a] -> [a]-t3_join = t3_infix (++)---- * P4 (4-product)--p4_fst :: (a,b,c,d) -> a-p4_fst (a,_,_,_) = a--p4_snd :: (a,b,c,d) -> b-p4_snd (_,b,_,_) = b--p4_third :: (a,b,c,d) -> c-p4_third (_,_,c,_) = c--p4_fourth :: (a,b,c,d) -> d-p4_fourth (_,_,_,d) = d--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)--t4_from_list :: [t] -> T4 t-t4_from_list l = case l of {[p,q,r,s] -> (p,q,r,s); _ -> error "t4_from_list"}--t4_to_list :: T4 t -> [t]-t4_to_list (p,q,r,s) = [p,q,r,s]--t4_fst :: T4 t -> t-t4_fst = p4_fst--t4_snd :: T4 t -> t-t4_snd = p4_snd--t4_third :: T4 t -> t-t4_third = p4_third--t4_fourth :: T4 t -> t-t4_fourth = p4_fourth--t4_map :: (p -> q) -> T4 p -> T4 q-t4_map f (p,q,r,s) = (f p,f q,f r,f s)--t4_zipWith :: (p -> q -> r) -> T4 p -> T4 q -> T4 r-t4_zipWith f (p,q,r,s) (p',q',r',s') = (f p p',f q q',f r r',f s s')--t4_infix :: (a -> a -> a) -> T4 a -> a-t4_infix f (i,j,k,l) = ((i `f` j) `f` k) `f` l--t4_join :: T4 [a] -> [a]-t4_join = t4_infix (++)---- * P5 (5-product)--p5_fst :: (a,b,c,d,e) -> a-p5_fst (a,_,_,_,_) = a--p5_snd :: (a,b,c,d,e) -> b-p5_snd (_,b,_,_,_) = b--p5_third :: (a,b,c,d,e) -> c-p5_third (_,_,c,_,_) = c--p5_fourth :: (a,b,c,d,e) -> d-p5_fourth (_,_,_,d,_) = d--p5_fifth :: (a,b,c,d,e) -> e-p5_fifth (_,_,_,_,e) = e--p5_from_list :: (t -> t1, t -> t2, t -> t3, t -> t4, t -> t5) -> [t] -> (t1,t2,t3,t4,t5)-p5_from_list (f1,f2,f3,f4,f5) l =-  case l of-    [c1,c2,c3,c4,c5] -> (f1 c1,f2 c2,f3 c3,f4 c4,f5 c5)-    _ -> error "p5_from_list"---p5_to_list :: (t1 -> t, t2 -> t, t3 -> t, t4 -> t, t5 -> t) -> (t1, t2, t3, t4, t5) -> [t]-p5_to_list (f1,f2,f3,f4,f5) (c1,c2,c3,c4,c5) = [f1 c1,f2 c2,f3 c3,f4 c4,f5 c5]---- * T5 (5-tuple, regular)--type T5 a = (a,a,a,a,a)--t5_from_list :: [t] -> T5 t-t5_from_list l = case l of {[p,q,r,s,t] -> (p,q,r,s,t); _ -> error "t5_from_list"}--t5_to_list :: T5 t -> [t]-t5_to_list (p,q,r,s,t) = [p,q,r,s,t]--t5_map :: (p -> q) -> T5 p -> T5 q-t5_map f (p,q,r,s,t) = (f p,f q,f r,f s,f t)--t5_fst :: T5 t -> t-t5_fst (p,_,_,_,_) = p--t5_snd :: T5 t -> t-t5_snd (_,q,_,_,_) = q--t5_fourth :: T5 t -> t-t5_fourth (_,_,_,t,_) = t--t5_fifth :: T5 t -> t-t5_fifth (_,_,_,_,u) = u--t5_infix :: (a -> a -> a) -> T5 a -> a-t5_infix f (i,j,k,l,m) = (((i `f` j) `f` k) `f` l) `f` m--t5_join :: T5 [a] -> [a]-t5_join = t5_infix (++)---- * P6 (6-product)--p6_fst :: (a,b,c,d,e,f) -> a-p6_fst (a,_,_,_,_,_) = a--p6_snd :: (a,b,c,d,e,f) -> b-p6_snd (_,b,_,_,_,_) = b--p6_third :: (a,b,c,d,e,f) -> c-p6_third (_,_,c,_,_,_) = c--p6_fourth :: (a,b,c,d,e,f) -> d-p6_fourth (_,_,_,d,_,_) = d--p6_fifth :: (a,b,c,d,e,f) -> e-p6_fifth (_,_,_,_,e,_) = e--p6_sixth :: (a,b,c,d,e,f) -> f-p6_sixth (_,_,_,_,_,f) = f---- * T6 (6-tuple, regular)--type T6 a = (a,a,a,a,a,a)--t6_from_list :: [t] -> T6 t-t6_from_list l = case l of {[p,q,r,s,t,u] -> (p,q,r,s,t,u);_ -> error "t6_from_list"}--t6_to_list :: T6 t -> [t]-t6_to_list (p,q,r,s,t,u) = [p,q,r,s,t,u]--t6_map :: (p -> q) -> T6 p -> T6 q-t6_map f (p,q,r,s,t,u) = (f p,f q,f r,f s,f t,f u)---- * T7 (7-tuple, regular)--type T7 a = (a,a,a,a,a,a,a)--t7_to_list :: T7 t -> [t]-t7_to_list (p,q,r,s,t,u,v) = [p,q,r,s,t,u,v]--t7_map :: (p -> q) -> T7 p -> T7 q-t7_map f (p,q,r,s,t,u,v) = (f p,f q,f r,f s,f t,f u,f v)---- * T8 (8-tuple, regular)--type T8 a = (a,a,a,a,a,a,a,a)--t8_to_list :: T8 t -> [t]-t8_to_list (p,q,r,s,t,u,v,w) = [p,q,r,s,t,u,v,w]--t8_map :: (p -> q) -> T8 p -> T8 q-t8_map f (p,q,r,s,t,u,v,w) = (f p,f q,f r,f s,f t,f u,f v,f w)---- * P8 (8-product)--p8_third :: (a,b,c,d,e,f,g,h) -> c-p8_third (_,_,c,_,_,_,_,_) = c---- * T9 (9-tuple, regular)--type T9 a = (a,a,a,a,a,a,a,a,a)--t9_to_list :: T9 t -> [t]-t9_to_list (p,q,r,s,t,u,v,w,x) = [p,q,r,s,t,u,v,w,x]--t9_map :: (p -> q) -> T9 p -> T9 q-t9_map f (p,q,r,s,t,u,v,w,x) = (f p,f q,f r,f s,f t,f u,f v,f w,f x)---- * T10 (10-tuple, regular)--type T10 a = (a,a,a,a,a,a,a,a,a,a)--t10_to_list :: T10 t -> [t]-t10_to_list (p,q,r,s,t,u,v,w,x,y) = [p,q,r,s,t,u,v,w,x,y]--t10_map :: (p -> q) -> T10 p -> T10 q-t10_map f (p,q,r,s,t,u,v,w,x,y) = (f p,f q,f r,f s,f t,f u,f v,f w,f x,f y)---- * T11 (11-tuple, regular)--type T11 a = (a,a,a,a,a,a,a,a,a,a,a)--t11_to_list :: T11 t -> [t]-t11_to_list (p,q,r,s,t,u,v,w,x,y,z) = [p,q,r,s,t,u,v,w,x,y,z]--t11_map :: (p -> q) -> T11 p -> T11 q-t11_map f (p,q,r,s,t,u,v,w,x,y,z) = (f p,f q,f r,f s,f t,f u,f v,f w,f x,f y,f z)---- * T12 (12-tuple, regular)--type T12 t = (t,t,t,t,t,t,t,t,t,t,t,t)--t12_to_list :: T12 t -> [t]-t12_to_list (p,q,r,s,t,u,v,w,x,y,z,a) = [p,q,r,s,t,u,v,w,x,y,z,a]--t12_from_list :: [t] -> T12 t-t12_from_list l =-    case l of-      [p,q,r,s,t,u,v,w,x,y,z,a] -> (p,q,r,s,t,u,v,w,x,y,z,a)-      _ -> error "t12_from_list"---- | 'foldr1' of 't12_to_list'.------ > t12_foldr1 (+) (1,2,3,4,5,6,7,8,9,10,11,12) == 78-t12_foldr1 :: (t -> t -> t) -> T12 t -> t-t12_foldr1 f = foldr1 f . t12_to_list---- | 'sum' of 't12_to_list'.------ > t12_sum (1,2,3,4,5,6,7,8,9,10,11,12) == 78-t12_sum :: Num n => T12 n -> n-t12_sum t =-    let (n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12) = t-    in n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8 + n9 + n10 + n11 + n12---- * Family of 'uncurry' functions.--uncurry3 :: (a->b->c -> z) -> (a,b,c) -> z-uncurry3 fn (a,b,c) = fn a b c-uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d) -> z-uncurry4 fn (a,b,c,d) = fn a b c d-uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e) -> z-uncurry5 fn (a,b,c,d,e) = fn a b c d e-uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f) -> z-uncurry6 fn (a,b,c,d,e,f) = fn a b c d e f-uncurry7 :: (a->b->c->d->e->f->g -> z) -> (a,b,c,d,e,f,g) -> z-uncurry7 fn (a,b,c,d,e,f,g) = fn a b c d e f g-uncurry8 :: (a->b->c->d->e->f->g->h -> z) -> (a,b,c,d,e,f,g,h) -> z-uncurry8 fn (a,b,c,d,e,f,g,h) = fn a b c d e f g h-uncurry9 :: (a->b->c->d->e->f->g->h->i -> z) -> (a,b,c,d,e,f,g,h,i) -> z-uncurry9 fn (a,b,c,d,e,f,g,h,i) = fn a b c d e f g h i-uncurry10 :: (a->b->c->d->e->f->g->h->i->j -> z) -> (a,b,c,d,e,f,g,h,i,j) -> z-uncurry10 fn (a,b,c,d,e,f,g,h,i,j) = fn a b c d e f g h i j-uncurry11 :: (a->b->c->d->e->f->g->h->i->j->k -> z) -> (a,b,c,d,e,f,g,h,i,j,k) -> z-uncurry11 fn (a,b,c,d,e,f,g,h,i,j,k) = fn a b c d e f g h i j k-uncurry12 :: (a->b->c->d->e->f->g->h->i->j->k->l -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l) -> z-uncurry12 fn (a,b,c,d,e,f,g,h,i,j,k,l) = fn a b c d e f g h i j k l-uncurry13 :: (a->b->c->d->e->f->g->h->i->j->k->l->m -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) -> z-uncurry13 fn (a,b,c,d,e,f,g,h,i,j,k,l,m) = fn a b c d e f g h i j k l m-uncurry14 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> z-uncurry14 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = fn a b c d e f g h i j k l m n-uncurry15 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -> z-uncurry15 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = fn a b c d e f g h i j k l m n o-uncurry16 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> z-uncurry16 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = fn a b c d e f g h i j k l m n o p-uncurry17 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) -> z-uncurry17 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = fn a b c d e f g h i j k l m n o p q-uncurry18 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) -> z-uncurry18 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = fn a b c d e f g h i j k l m n o p q r-uncurry19 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) -> z-uncurry19 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = fn a b c d e f g h i j k l m n o p q r s-uncurry20 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) -> z-uncurry20 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = fn a b c d e f g h i j k l m n o p q r s t---- Local Variables:--- truncate-lines:t--- End:
− Music/Theory/Unicode.hs 
@@ -1,508 +0,0 @@--- | <http://www.unicode.org/charts/PDF/U1D100.pdf>------ These symbols are in <http://www.gnu.org/software/freefont/>,--- debian=ttf-freefont.-module Music.Theory.Unicode where--import Data.Char {- base -}-import Data.List {- base -}-import Numeric {- base -}--import qualified Text.CSV.Lazy.String as C {- lazy-csv -}--import qualified Music.Theory.IO as T {- hmt -}-import qualified Music.Theory.List as T {- hmt -}-import qualified Music.Theory.Read as T {- hmt -}---- * Non-music---- | Unicode non breaking hypen character.------ > non_breaking_hypen == '‑'-non_breaking_hypen :: Char-non_breaking_hypen = toEnum 0x2011---- | Unicode non breaking space character.------ > non_breaking_space == ' '-non_breaking_space :: Char-non_breaking_space = toEnum 0x00A0---- | 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,Unicode_Name)-type Unicode_Table = [Unicode_Point]--{- | <http://unicode.org/Public/11.0.0/ucd/UnicodeData.txt>--> let fn = "/home/rohan/data/unicode.org/Public/11.0.0/ucd/UnicodeData.txt"-> tbl <- unicode_data_table_read fn-> length tbl == 32292-> T.reverse_lookup_err "MIDDLE DOT" tbl == 0x00B7-> putStrLn $ unwords $ map (\(n,x) -> toEnum n : x) $ filter (\(_,x) -> "EMPTY SET" `isInfixOf` x) tbl-> T.lookup_err 0x22C5 tbl == "DOT OPERATOR"--}-unicode_data_table_read :: FilePath -> IO Unicode_Table-unicode_data_table_read fn = do-  s <- T.read_file_utf8 fn-  let t = C.fromCSVTable (C.csvTable (C.parseDSV False ';' s))-      f x = (T.read_hex_err (x !! 0),x !! 1)-  return (map f t)--unicode_table_block :: (Unicode_Index,Unicode_Index) -> Unicode_Table -> Unicode_Table-unicode_table_block (l,r) = takeWhile ((<= r) . fst) . dropWhile ((< l) . fst)--unicode_point_hs :: Unicode_Point -> String-unicode_point_hs (n,s) = concat ["(0x",showHex n "",",\"",s,"\")"]--unicode_table_hs :: Unicode_Table -> String-unicode_table_hs = T.bracket ('[',']') . intercalate "," . map unicode_point_hs---- * Music---- > putStrLn$ map (toEnum . fst) (concat music_tbl)-music_tbl :: [Unicode_Table]-music_tbl = [barlines_tbl,accidentals_tbl,notes_tbl,rests_tbl,clefs_tbl]---- > putStrLn$ concatMap (unicode_table_hs . flip unicode_table_block tbl) accidentals_rng_set-accidentals_rng_set :: [Unicode_Range]-accidentals_rng_set = [(0x266D,0x266F),(0x1D12A,0x1D133)]---- > putStrLn$ unicode_table_hs (unicode_table_block barlines_rng tbl)-barlines_rng :: Unicode_Range-barlines_rng = (0x1D100,0x1D105)---- | UNICODE barline symbols.------ > let r = "𝄀𝄁𝄂𝄃𝄄𝄅" in map (toEnum . fst) barlines_tbl == r-barlines_tbl :: Unicode_Table-barlines_tbl =-  [(0x1D100,"MUSICAL SYMBOL SINGLE BARLINE")-  ,(0x1D101,"MUSICAL SYMBOL DOUBLE BARLINE")-  ,(0x1D102,"MUSICAL SYMBOL FINAL BARLINE")-  ,(0x1D103,"MUSICAL SYMBOL REVERSE FINAL BARLINE")-  ,(0x1D104,"MUSICAL SYMBOL DASHED BARLINE")-  ,(0x1D105,"MUSICAL SYMBOL SHORT BARLINE")]---- | UNICODE accidental symbols.------ > let r = "♭♮♯𝄪𝄫𝄬𝄭𝄮𝄯𝄰𝄱𝄲𝄳" in map (toEnum . fst) accidentals_tbl == r-accidentals_tbl :: Unicode_Table-accidentals_tbl =-    [(0x266D,"MUSIC FLAT SIGN")-    ,(0x266E,"MUSIC NATURAL SIGN")-    ,(0x266F,"MUSIC SHARP SIGN")-    ,(0x1D12A,"MUSICAL SYMBOL DOUBLE SHARP")-    ,(0x1D12B,"MUSICAL SYMBOL DOUBLE FLAT")-    ,(0x1D12C,"MUSICAL SYMBOL FLAT UP")-    ,(0x1D12D,"MUSICAL SYMBOL FLAT DOWN")-    ,(0x1D12E,"MUSICAL SYMBOL NATURAL UP")-    ,(0x1D12F,"MUSICAL SYMBOL NATURAL DOWN")-    ,(0x1D130,"MUSICAL SYMBOL SHARP UP")-    ,(0x1D131,"MUSICAL SYMBOL SHARP DOWN")-    ,(0x1D132,"MUSICAL SYMBOL QUARTER TONE SHARP")-    ,(0x1D133,"MUSICAL SYMBOL QUARTER TONE FLAT")]---- > putStrLn$ unicode_table_hs (unicode_table_block notes_rng tbl)-notes_rng :: Unicode_Range-notes_rng = (0x1D15C,0x1D164)---- | UNICODE note duration symbols.------ > let r = "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲" in map (toEnum . fst) notes_tbl == r-notes_tbl :: Unicode_Table-notes_tbl =-    [(0x1D15C,"MUSICAL SYMBOL BREVE")-    ,(0x1D15D,"MUSICAL SYMBOL WHOLE NOTE")-    ,(0x1D15E,"MUSICAL SYMBOL HALF NOTE")-    ,(0x1D15F,"MUSICAL SYMBOL QUARTER NOTE")-    ,(0x1D160,"MUSICAL SYMBOL EIGHTH NOTE")-    ,(0x1D161,"MUSICAL SYMBOL SIXTEENTH NOTE")-    ,(0x1D162,"MUSICAL SYMBOL THIRTY-SECOND NOTE")-    ,(0x1D163,"MUSICAL SYMBOL SIXTY-FOURTH NOTE")-    ,(0x1D164,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE")]---- > putStrLn$ unicode_table_hs (unicode_table_block rests_rng tbl)-rests_rng :: Unicode_Range-rests_rng = (0x1D13B,0x1D142)---- | UNICODE rest symbols.------ > let r = "𝄻𝄼𝄽𝄾𝄿𝅀𝅁𝅂" in map (toEnum . fst) rests_tbl == r-rests_tbl :: Unicode_Table-rests_tbl =-    [(0x1D13B,"MUSICAL SYMBOL WHOLE REST")-    ,(0x1D13C,"MUSICAL SYMBOL HALF REST")-    ,(0x1D13D,"MUSICAL SYMBOL QUARTER REST")-    ,(0x1D13E,"MUSICAL SYMBOL EIGHTH REST")-    ,(0x1D13F,"MUSICAL SYMBOL SIXTEENTH REST")-    ,(0x1D140,"MUSICAL SYMBOL THIRTY-SECOND REST")-    ,(0x1D141,"MUSICAL SYMBOL SIXTY-FOURTH REST")-    ,(0x1D142,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH REST")]---- | Augmentation dot.------ > map toEnum [0x1D15E,0x1D16D,0x1D16D] == "𝅗𝅥𝅭𝅭"-augmentation_dot :: Unicode_Point-augmentation_dot = (0x1D16D, "MUSICAL SYMBOL COMBINING AUGMENTATION DOT")---- > putStrLn$ unicode_table_hs (unicode_table_block clefs_rng tbl)-clefs_rng :: Unicode_Range-clefs_rng = (0x1D11E,0x1D126)---- | UNICODE clef symbols.------ > let r = "𝄞𝄟𝄠𝄡𝄢𝄣𝄤𝄥𝄦" in map (toEnum . fst) clefs_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")-    ,(0x1D121,"MUSICAL SYMBOL C CLEF")-    ,(0x1D122,"MUSICAL SYMBOL F CLEF")-    ,(0x1D123,"MUSICAL SYMBOL F CLEF OTTAVA ALTA")-    ,(0x1D124,"MUSICAL SYMBOL F CLEF OTTAVA BASSA")-    ,(0x1D125,"MUSICAL SYMBOL DRUM CLEF-1")-    ,(0x1D126,"MUSICAL SYMBOL DRUM CLEF-2")]---- > 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_tbl == r-noteheads_tbl :: Unicode_Table-noteheads_tbl =-    [(0x1d143,"MUSICAL SYMBOL X NOTEHEAD")-    ,(0x1d144,"MUSICAL SYMBOL PLUS NOTEHEAD")-    ,(0x1d145,"MUSICAL SYMBOL CIRCLE X NOTEHEAD")-    ,(0x1d146,"MUSICAL SYMBOL SQUARE NOTEHEAD WHITE")-    ,(0x1d147,"MUSICAL SYMBOL SQUARE NOTEHEAD BLACK")-    ,(0x1d148,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP WHITE")-    ,(0x1d149,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP BLACK")-    ,(0x1d14a,"MUSICAL SYMBOL TRIANGLE NOTEHEAD LEFT WHITE")-    ,(0x1d14b,"MUSICAL SYMBOL TRIANGLE NOTEHEAD LEFT BLACK")-    ,(0x1d14c,"MUSICAL SYMBOL TRIANGLE NOTEHEAD RIGHT WHITE")-    ,(0x1d14d,"MUSICAL SYMBOL TRIANGLE NOTEHEAD RIGHT BLACK")-    ,(0x1d14e,"MUSICAL SYMBOL TRIANGLE NOTEHEAD DOWN WHITE")-    ,(0x1d14f,"MUSICAL SYMBOL TRIANGLE NOTEHEAD DOWN BLACK")-    ,(0x1d150,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP RIGHT WHITE")-    ,(0x1d151,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP RIGHT BLACK")-    ,(0x1d152,"MUSICAL SYMBOL MOON NOTEHEAD WHITE")-    ,(0x1d153,"MUSICAL SYMBOL MOON NOTEHEAD BLACK")-    ,(0x1d154,"MUSICAL SYMBOL TRIANGLE-ROUND NOTEHEAD DOWN WHITE")-    ,(0x1d155,"MUSICAL SYMBOL TRIANGLE-ROUND NOTEHEAD DOWN BLACK")-    ,(0x1d156,"MUSICAL SYMBOL PARENTHESIS NOTEHEAD")-    ,(0x1d157,"MUSICAL SYMBOL VOID NOTEHEAD")-    ,(0x1d158,"MUSICAL SYMBOL NOTEHEAD BLACK")-    ,(0x1d159,"MUSICAL SYMBOL NULL NOTEHEAD")-    ,(0x1d15a,"MUSICAL SYMBOL CLUSTER NOTEHEAD WHITE")-    ,(0x1d15b,"MUSICAL SYMBOL CLUSTER NOTEHEAD BLACK")]---- > map toEnum [0x1D143,0x1D165] == "𝅃𝅥"-stem :: Unicode_Point-stem = (0x1D165, "MUSICAL SYMBOL COMBINING STEM")---- > putStrLn$ unicode_table_hs (unicode_table_block dynamics_rng tbl)-dynamics_rng :: Unicode_Range-dynamics_rng = (0x1D18C,0x1D193)---- > map (toEnum . fst) dynamics_tbl == "𝆌𝆍𝆎𝆏𝆐𝆑𝆒𝆓"-dynamics_tbl :: Unicode_Table-dynamics_tbl =-    [(0x1d18c,"MUSICAL SYMBOL RINFORZANDO")-    ,(0x1d18d,"MUSICAL SYMBOL SUBITO")-    ,(0x1d18e,"MUSICAL SYMBOL Z")-    ,(0x1d18f,"MUSICAL SYMBOL PIANO")-    ,(0x1d190,"MUSICAL SYMBOL MEZZO")-    ,(0x1d191,"MUSICAL SYMBOL FORTE")-    ,(0x1d192,"MUSICAL SYMBOL CRESCENDO")-    ,(0x1d193,"MUSICAL SYMBOL DECRESCENDO")]---- > putStrLn$ unicode_table_hs (unicode_table_block articulations_rng tbl)-articulations_rng :: Unicode_Range-articulations_rng = (0x1D17B,0x1D18B)---- > putStrLn (map (toEnum . fst) articulations_tbl :: String)-articulations_tbl :: Unicode_Table-articulations_tbl =-    [(0x1d17b,"MUSICAL SYMBOL COMBINING ACCENT")-    ,(0x1d17c,"MUSICAL SYMBOL COMBINING STACCATO")-    ,(0x1d17d,"MUSICAL SYMBOL COMBINING TENUTO")-    ,(0x1d17e,"MUSICAL SYMBOL COMBINING STACCATISSIMO")-    ,(0x1d17f,"MUSICAL SYMBOL COMBINING MARCATO")-    ,(0x1d180,"MUSICAL SYMBOL COMBINING MARCATO-STACCATO")-    ,(0x1d181,"MUSICAL SYMBOL COMBINING ACCENT-STACCATO")-    ,(0x1d182,"MUSICAL SYMBOL COMBINING LOURE")-    ,(0x1d183,"MUSICAL SYMBOL ARPEGGIATO UP")-    ,(0x1d184,"MUSICAL SYMBOL ARPEGGIATO DOWN")-    ,(0x1d185,"MUSICAL SYMBOL COMBINING DOIT")-    ,(0x1d186,"MUSICAL SYMBOL COMBINING RIP")-    ,(0x1d187,"MUSICAL SYMBOL COMBINING FLIP")-    ,(0x1d188,"MUSICAL SYMBOL COMBINING SMEAR")-    ,(0x1d189,"MUSICAL SYMBOL COMBINING BEND")-    ,(0x1d18a,"MUSICAL SYMBOL COMBINING DOUBLE TONGUE")-    ,(0x1d18b,"MUSICAL SYMBOL COMBINING TRIPLE TONGUE")]---- * 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)---- > putStrLn$ unicode_table_hs (concatMap (flip unicode_table_block tbl . fst) unicode_blocks)-unicode_blocks :: [Unicode_Block]-unicode_blocks =-    [((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")-    ]---- * BAGUA, EIGHT TRI-GRAMS---- | Bagua tri-grams.------ > putStrLn $ unicode_table_hs (unicode_table_block (fst bagua) tbl)-bagua :: Unicode_Block-bagua = ((0x02630,0x02637),"BAGUA")--{- | Table of eight tri-grams.--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---}-bagua_tbl :: Unicode_Table-bagua_tbl =-  [(0x2630,"TRIGRAM FOR HEAVEN")-  ,(0x2631,"TRIGRAM FOR LAKE")-  ,(0x2632,"TRIGRAM FOR FIRE")-  ,(0x2633,"TRIGRAM FOR THUNDER")-  ,(0x2634,"TRIGRAM FOR WIND")-  ,(0x2635,"TRIGRAM FOR WATER")-  ,(0x2636,"TRIGRAM FOR MOUNTAIN")-  ,(0x2637,"TRIGRAM FOR EARTH")]---- * YIJING (I-CHING), SIXTY-FOUR HEXAGRAMS---- | Yijing hexagrams in King Wen sequence.------ > putStrLn $ unicode_table_hs (unicode_table_block (fst yijing) tbl)-yijing :: Unicode_Block-yijing = ((0x04DC0,0x04DFF),"YIJING")--{- | Yijing hexagrams in King Wen sequence.--䷀,乾,qián,111,111-䷁,坤,kūn,000,000-䷂,屯,chún,100,010-䷃,蒙,méng,010,001-䷄,需,xū,111,010-䷅,訟,sòng,010,111-䷆,師,shī,010,000-䷇,比,bǐ,000,010-䷈,小畜,xiǎo chù,111,011-䷉,履,lǚ,110,111-䷊,泰,tài,111,000-䷋,否,pǐ,000,111-䷌,同人,tóng rén,101,111-䷍,大有,dà yǒu,111,101-䷎,謙,qiān,001,000-䷏,豫,yù,000,100-䷐,隨,suí,100,110-䷑,蠱,gŭ,011,001-䷒,臨,lín,110,000-䷓,觀,guān,000,011-䷔,噬嗑,shì kè,100,101-䷕,賁,bì,101,001-䷖,剝,bō,000,001-䷗,復,fù,100,000-䷘,無妄,wú wàng,100,111-䷙,大畜,dà chù,111,001-䷚,頤,yí,100,001-䷛,大過,dà guò,011,110-䷜,坎,kǎn,010,010-䷝,離,lí,101,101-䷞,咸,xián,001,110-䷟,恆,héng,011,100-䷠,遯,dùn,001,111-䷡,大壯,dà zhuàng,111,100-䷢,晉,jìn,000,101-䷣,明夷,míng yí,101,000-䷤,家人,jiā rén,101,011-䷥,睽,kuí,110,101-䷦,蹇,jiǎn,001,010-䷧,解,xiè,010,100-䷨,損,sǔn,110,001-䷩,益,yì,100,011-䷪,夬,guài,111,110-䷫,姤,gòu,011,111-䷬,萃,cuì,000,110-䷭,升,shēng,011,000-䷮,困,kùn,010,110-䷯,井,jǐng,011,010-䷰,革,gé,101,110-䷱,鼎,dǐng,011,101-䷲,震,zhèn,100,100-䷳,艮,gèn,001,001-䷴,漸,jiàn,001,011-䷵,歸妹,guī mèi,110,100-䷶,豐,fēng,101,100-䷷,旅,lǚ,001,101-䷸,巽,xùn,011,011-䷹,兌,duì,110,110-䷺,渙,huàn,010,011-䷻,節,jié,110,010-䷼,中孚,zhōng fú,110,011-䷽,小過,xiǎo guò,001,110-䷾,既濟,jì jì,101,010-䷿,未濟,wèi jì,010,101--}-yijing_tbl :: Unicode_Table-yijing_tbl =-  [(0x4dc0,"HEXAGRAM FOR THE CREATIVE HEAVEN")-  ,(0x4dc1,"HEXAGRAM FOR THE RECEPTIVE EARTH")-  ,(0x4dc2,"HEXAGRAM FOR DIFFICULTY AT THE BEGINNING")-  ,(0x4dc3,"HEXAGRAM FOR YOUTHFUL FOLLY")-  ,(0x4dc4,"HEXAGRAM FOR WAITING")-  ,(0x4dc5,"HEXAGRAM FOR CONFLICT")-  ,(0x4dc6,"HEXAGRAM FOR THE ARMY")-  ,(0x4dc7,"HEXAGRAM FOR HOLDING TOGETHER")-  ,(0x4dc8,"HEXAGRAM FOR SMALL TAMING")-  ,(0x4dc9,"HEXAGRAM FOR TREADING")-  ,(0x4dca,"HEXAGRAM FOR PEACE")-  ,(0x4dcb,"HEXAGRAM FOR STANDSTILL")-  ,(0x4dcc,"HEXAGRAM FOR FELLOWSHIP")-  ,(0x4dcd,"HEXAGRAM FOR GREAT POSSESSION")-  ,(0x4dce,"HEXAGRAM FOR MODESTY")-  ,(0x4dcf,"HEXAGRAM FOR ENTHUSIASM")-  ,(0x4dd0,"HEXAGRAM FOR FOLLOWING")-  ,(0x4dd1,"HEXAGRAM FOR WORK ON THE DECAYED")-  ,(0x4dd2,"HEXAGRAM FOR APPROACH")-  ,(0x4dd3,"HEXAGRAM FOR CONTEMPLATION")-  ,(0x4dd4,"HEXAGRAM FOR BITING THROUGH")-  ,(0x4dd5,"HEXAGRAM FOR GRACE")-  ,(0x4dd6,"HEXAGRAM FOR SPLITTING APART")-  ,(0x4dd7,"HEXAGRAM FOR RETURN")-  ,(0x4dd8,"HEXAGRAM FOR INNOCENCE")-  ,(0x4dd9,"HEXAGRAM FOR GREAT TAMING")-  ,(0x4dda,"HEXAGRAM FOR MOUTH CORNERS")-  ,(0x4ddb,"HEXAGRAM FOR GREAT PREPONDERANCE")-  ,(0x4ddc,"HEXAGRAM FOR THE ABYSMAL WATER")-  ,(0x4ddd,"HEXAGRAM FOR THE CLINGING FIRE")-  ,(0x4dde,"HEXAGRAM FOR INFLUENCE")-  ,(0x4ddf,"HEXAGRAM FOR DURATION")-  ,(0x4de0,"HEXAGRAM FOR RETREAT")-  ,(0x4de1,"HEXAGRAM FOR GREAT POWER")-  ,(0x4de2,"HEXAGRAM FOR PROGRESS")-  ,(0x4de3,"HEXAGRAM FOR DARKENING OF THE LIGHT")-  ,(0x4de4,"HEXAGRAM FOR THE FAMILY")-  ,(0x4de5,"HEXAGRAM FOR OPPOSITION")-  ,(0x4de6,"HEXAGRAM FOR OBSTRUCTION")-  ,(0x4de7,"HEXAGRAM FOR DELIVERANCE")-  ,(0x4de8,"HEXAGRAM FOR DECREASE")-  ,(0x4de9,"HEXAGRAM FOR INCREASE")-  ,(0x4dea,"HEXAGRAM FOR BREAKTHROUGH")-  ,(0x4deb,"HEXAGRAM FOR COMING TO MEET")-  ,(0x4dec,"HEXAGRAM FOR GATHERING TOGETHER")-  ,(0x4ded,"HEXAGRAM FOR PUSHING UPWARD")-  ,(0x4dee,"HEXAGRAM FOR OPPRESSION")-  ,(0x4def,"HEXAGRAM FOR THE WELL")-  ,(0x4df0,"HEXAGRAM FOR REVOLUTION")-  ,(0x4df1,"HEXAGRAM FOR THE CAULDRON")-  ,(0x4df2,"HEXAGRAM FOR THE AROUSING THUNDER")-  ,(0x4df3,"HEXAGRAM FOR THE KEEPING STILL MOUNTAIN")-  ,(0x4df4,"HEXAGRAM FOR DEVELOPMENT")-  ,(0x4df5,"HEXAGRAM FOR THE MARRYING MAIDEN")-  ,(0x4df6,"HEXAGRAM FOR ABUNDANCE")-  ,(0x4df7,"HEXAGRAM FOR THE WANDERER")-  ,(0x4df8,"HEXAGRAM FOR THE GENTLE WIND")-  ,(0x4df9,"HEXAGRAM FOR THE JOYOUS LAKE")-  ,(0x4dfa,"HEXAGRAM FOR DISPERSION")-  ,(0x4dfb,"HEXAGRAM FOR LIMITATION")-  ,(0x4dfc,"HEXAGRAM FOR INNER TRUTH")-  ,(0x4dfd,"HEXAGRAM FOR SMALL PREPONDERANCE")-  ,(0x4dfe,"HEXAGRAM FOR AFTER COMPLETION")-  ,(0x4dff,"HEXAGRAM FOR BEFORE COMPLETION")]
Music/Theory/Wyschnegradsky.hs view
@@ -3,13 +3,14 @@  import Data.Char {- base -} import Data.List {- list -}-import Data.List.Split {- split -} import Data.Maybe {- base -} -import Music.Theory.List {- hmt -}-import Music.Theory.Pitch {- hmt -}-import Music.Theory.Pitch.Spelling.Table {- hmt -}+import qualified Data.List.Split as Split {- split -} +import qualified Music.Theory.List as List {- hmt -}+import qualified Music.Theory.Pitch as Pitch {- hmt -}+import qualified Music.Theory.Pitch.Spelling.Table as Spelling {- hmt -}+ -- | In a modulo /m/ system, normalise step increments to be either -1 -- or 1.  Non steps raise an error. --@@ -27,7 +28,7 @@ -- > map parse_num_sign ["2+","4-"] == [2,-4] parse_num_sign :: (Num n, Read n) => String -> n parse_num_sign s =-    case separate_last s of+    case List.separate_last s of       (n,'+') -> read n       (n,'-') -> negate (read n)       _ -> error "parse_num_sign"@@ -46,9 +47,9 @@ parse_vec :: Num n => Maybe Int -> n -> String -> [n] parse_vec n m =     let f = case n of-              Just i -> dx_d m . take i . cycle-              Nothing -> dx_d m-    in dropRight 1 . f . concatMap (vec_expand . parse_num_sign) . splitOn ","+              Just i -> List.dx_d m . take i . cycle+              Nothing -> List.dx_d m+    in List.dropRight 1 . f . concatMap (vec_expand . parse_num_sign) . Split.splitOn ","  -- | Modulo addition. add_m :: Integral a => a -> a -> a -> a@@ -82,13 +83,13 @@ seq_group :: Int -> Int -> Seq a -> [[a]] seq_group c_div r_div s =     case s of-      Circumferential c -> chunksOf c_div c-      Radial r -> transpose (chunksOf r_div r)+      Circumferential c -> Split.chunksOf c_div c+      Radial r -> transpose (Split.chunksOf r_div r)  -- | Printer for pitch-class segments. iw_pc_pp :: Integral n => String -> [[n]] -> IO () iw_pc_pp sep =-    let f = pitch_pp_opt (False,False) . octpc_to_pitch pc_spell_ks . (,) 4+    let f = Pitch.pitch_pp_opt (False,False) . Pitch.octpc_to_pitch Spelling.pc_spell_ks . (,) 4     in putStrLn . intercalate sep . map (unwords . map f)  -- * U3@@ -133,7 +134,7 @@ -- > let f = parse_vec Nothing 0 in map (\(p,q) -> (f p,f q)) u3_vec_text_rw -- -- > let f (c,r) = putStrLn (unlines ["C: " ++ c,"R: " ++ r])--- > in mapM_ f (interleave u3_vec_text_iw u3_vec_text_rw)+-- > mapM_ f (List.interleave u3_vec_text_iw u3_vec_text_rw) u3_vec_text_rw :: [(String, String)] u3_vec_text_rw =     [("4+,3-,5+,3-,3+"@@ -160,7 +161,7 @@ u3_vec_ix :: Num n => ([[n]],[[n]]) u3_vec_ix =     let f (p,q) = [parse_vec Nothing 0 p,parse_vec Nothing 0 q]-        [c,r] = transpose (map f u3_vec_text_rw)+        (c,r) = List.firstSecond (transpose (map f u3_vec_text_rw))     in (c,r)  -- | Radial indices (ie. each /ray/ as an index sequence).@@ -170,7 +171,7 @@ u3_ix_radial =     let (c,r) = u3_vec_ix         r' = zipWith replicate (map length c) r-    in zipWith (\p q -> map (add_m 6 p) q) (concat c) (concat r')+    in zipWith (map . add_m 6) (concat c) (concat r')  -- | Colour names in index sequence. u3_clr_nm :: [String]@@ -207,7 +208,7 @@     map length .     group .     map (normalise_step 6) .-    d_dx .+    List.d_dx .     map u3_ch_ix .     filter (not . isSpace) @@ -263,7 +264,7 @@             ,"#c2ba3d","#a2a367"             ,"#537a77","#203342"             ,"#84525e","#bc6460"]-        n = interleave [6,4,2,0,10,8] [5,3,1,11,9,7] :: [Int]+        n = List.interleave [6,4,2,0,10,8] [5,3,1,11,9,7] :: [Int]     in map snd (sort (zip n c))  -- | RGB form of colours.@@ -302,7 +303,7 @@  -- > iw_pc_pp "|" [u11_gen_seq 7 18 [5]] u11_gen_seq :: Integral i => i -> Int -> [i] -> [i]-u11_gen_seq z n = map (`mod` 12) . take n . dx_d z . cycle+u11_gen_seq z n = map (`mod` 12) . take n . List.dx_d z . cycle  u11_seq_rule :: Integral i => Maybe Int -> [i] u11_seq_rule n = u11_gen_seq 0 18 (maybe [-1] (\x -> replicate x (-1) ++ [5]) n)
Music/Theory/Xenakis/S4.hs view
@@ -6,8 +6,6 @@ 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 @@ -145,12 +143,12 @@  -- | Relation between to 'Half_Seq' values as a -- /(complementary,permutation)/ pair.-type Rel = (Bool,P.Permute)+type Rel = (Bool,T.Permutation)  -- | Determine 'Rel' of 'Half_Seq's. ----- > relate [1,4,2,3] [1,3,4,2] == (False,P.listPermute 4 [0,3,1,2])--- > relate [1,4,2,3] [8,5,6,7] == (True,P.listPermute 4 [1,0,2,3])+-- > relate [1,4,2,3] [1,3,4,2] == (False,[0,3,1,2])+-- > relate [1,4,2,3] [8,5,6,7] == (True,[1,0,2,3]) relate :: Half_Seq -> Half_Seq -> Rel relate p q =     if complementary p q@@ -159,7 +157,7 @@  -- | 'Rel' from 'Label' /p/ to /q/. ----- > relate_l L L2 == (False,P.listPermute 4 [0,3,1,2])+-- > relate_l L L2 == (False,[0,3,1,2]) relate_l :: Label -> Label -> Rel relate_l p q = relate (half_seq_of p) (half_seq_of q) @@ -169,14 +167,13 @@  -- | 'relate' adjacent 'Label's. ----- > relations_l [L2,L,A] == [(False,P.listPermute 4 [0,2,3,1])--- >                         ,(False,P.listPermute 4 [2,0,1,3])]+-- > relations_l [L2,L,A] == [(False,[0,2,3,1]),(False,[2,0,1,3])] relations_l :: [Label] -> [Rel] relations_l p = zipWith relate_l p (tail p)  -- | Apply 'Rel' to 'Half_Seq'. ----- > apply_relation (False,P.listPermute 4 [0,3,1,2]) [1,4,2,3] == [1,3,4,2]+-- > apply_relation (False,[0,3,1,2]) [1,4,2,3] == [1,3,4,2] apply_relation :: Rel -> Half_Seq -> Half_Seq apply_relation (c,p) i =     let j = T.apply_permutation p i
Music/Theory/Xenakis/Sieve.hs view
@@ -6,12 +6,9 @@ import qualified Data.List as L import Music.Theory.List --- | Synonym for 'Integer'-type I = Integer- -- | A Sieve. data Sieve = Empty -- ^ 'Empty' 'Sieve'-           | L (I,I) -- ^ Primitive 'Sieve' of /modulo/ and /index/+           | L (Integer, Integer) -- ^ Primitive 'Sieve' of /modulo/ and /index/            | Union Sieve Sieve -- ^ 'Union' of two 'Sieve's            | Intersection Sieve Sieve -- ^ 'Intersection' of two 'Sieve's            | Complement Sieve -- ^ 'Complement' of a 'Sieve'@@ -50,21 +47,22 @@ -- | Variant of 'L', ie. 'curry' 'L'. -- -- > l 15 19 == L (15,19)-l :: I -> I -> Sieve+l :: Integer -> Integer -> Sieve l = curry L  -- | unicode synonym for 'l'.-(⋄) :: I -> I -> Sieve+(⋄) :: Integer -> Integer -> Sieve (⋄) = l  infixl 3 ∪ infixl 4 ∩ infixl 5 ⋄ --- | In a /normal/ 'Sieve' /m/ is '>' /i/.------ > normalise (L (15,19)) == L (15,4)--- > normalise (L (11,13)) == L (11,2)+{- | In a /normal/ 'Sieve' /m/ is '>' /i/.++> normalise (L (15,19)) == L (15,4)+> normalise (L (11,13)) == L (11,2)+-} normalise :: Sieve -> Sieve normalise s =     case s of@@ -74,18 +72,20 @@       Intersection s0 s1 -> Intersection (normalise s0) (normalise s1)       Complement s' -> Complement (normalise s') --- | Predicate to test if a 'Sieve' is /normal/.------ > is_normal (L (15,4)) == True--- > is_normal (L (11,13)) == False+{- | Predicate to test if a 'Sieve' is /normal/.++> is_normal (L (15,4)) == True+> is_normal (L (11,13)) == False+-} is_normal :: Sieve -> Bool is_normal s = s == normalise s --- | Predicate to determine if an 'I' is an element of the 'Sieve'.------ > map (element (L (3,1))) [1..4] == [True,False,False,True]--- > map (element (L (15,4))) [4,19 .. 49] == [True,True,True,True]-element :: Sieve -> I -> Bool+{- | Predicate to determine if an 'I' is an element of the 'Sieve'.++> map (element (L (3,1))) [1..4] == [True,False,False,True]+> map (element (L (15,4))) [4,19 .. 49] == [True,True,True,True]+-}+element :: Sieve -> Integer -> Bool element s n =     case s of       Empty -> False@@ -94,8 +94,11 @@       Intersection s0 s1 -> element s0 n && element s1 n       Complement s' -> not (element s' n) --- > take 9 (i_complement [1,3..]) == [0,2..16]-i_complement :: [I] -> [I]+{- | 'I' not in set.++> take 9 (i_complement [1,3..]) == [0,2..16]+-}+i_complement :: [Integer] -> [Integer] i_complement =     let f x s = case s of                 [] -> [x ..]@@ -105,14 +108,15 @@                           GT -> error "i_complement"     in f 0 --- | Construct the sequence defined by a 'Sieve'.  Note that building--- a sieve that contains an intersection clause that has no elements--- gives @_|_@.------ > let {d = [0,2,4,5,7,9,11]--- >     ;r = d ++ map (+ 12) d}--- > in take 14 (build (union (map (l 12) d))) == r-build :: Sieve -> [I]+{- | Construct the sequence defined by a 'Sieve'.  Note that building+     a sieve that contains an intersection clause that has no elements+     gives @_|_@.++> let d = [0,2,4,5,7,9,11]+> let r = d ++ map (+ 12) d+> take 14 (build (union (map (l 12) d))) == r+-}+build :: Sieve -> [Integer] build s =     let u_f = map head . L.group         i_f = let g [x,_] = [x]@@ -125,8 +129,7 @@          Intersection s0 s1 -> i_f (merge (build s0) (build s1))          Complement s' -> i_complement (build s') -{- | Variant of 'build' that gives the first /n/ places of the-  'reduce' of 'Sieve'.+{- | Variant of 'build' that gives the first /n/ places of the 'reduce' of 'Sieve'.  > buildn 6 (union (map (l 8) [0,3,6])) == [0,3,6,8,11,14] > buildn 12 (L (3,2)) == [2,5,8,11,14,17,20,23,26,29,32,35]@@ -137,117 +140,105 @@ > buildn 6 (3⋄0 ∪ 4⋄0) == [0,3,4,6,8,9] > buildn 8 (5⋄2 ∩ 2⋄0 ∪ 7⋄3) == [2,3,10,12,17,22,24,31] > buildn 12 (5⋄1 ∪ 7⋄2) == [1,2,6,9,11,16,21,23,26,30,31,36]+> buildn 19 (L (3,2) ∪ L (7, 1)) == [1, 2, 5, 8, 11, 14, 15, 17, 20, 22, 23, 26, 29, 32, 35, 36, 38, 41, 43]+> buildn 19 (3⋄0 ∪ 7⋄0) == [0, 3, 6, 7, 9, 12, 14, 15, 18, 21, 24, 27, 28, 30, 33, 35, 36, 39, 42]  > buildn 10 (3⋄2 ∩ 4⋄7 ∪ 6⋄9 ∩ 15⋄18) == [3,11,23,33,35,47,59,63,71,83] -> let {s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19->     ;s' = 24⋄23 ∪ 30⋄3 ∪ 104⋄70}-> in buildn 16 s == buildn 16 s'+> let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19+> let s' = 24⋄23 ∪ 30⋄3 ∪ 104⋄70+> buildn 16 s == buildn 16 s'  > buildn 10 (24⋄23 ∪ 30⋄3 ∪ 104⋄70) == [3,23,33,47,63,70,71,93,95,119]  > let r = [2,3,4,5,8,9,10,11,14,17,19,20,23,24,26,29,31]-> in buildn 17 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == r+> buildn 17 (5⋄4 ∪ 3⋄2 ∪ 7⋄3) == r  > let r = [0,1,3,6,9,10,11,12,15,16,17,18,21,24,26,27,30]-> in buildn 17 (5⋄1 ∪ 3⋄0 ∪ 7⋄3) == r+> buildn 17 (5⋄1 ∪ 3⋄0 ∪ 7⋄3) == r  > let r = [0,2,3,4,6,7,9,11,12,15,17,18,21,22,24,25,27,30,32]-> in buildn 19 (5⋄2 ∪ 3⋄0 ∪ 7⋄4) == r+> buildn 19 (5⋄2 ∪ 3⋄0 ∪ 7⋄4) == r  Agon et. al. p.155 -> let {a = c (13⋄3 ∪ 13⋄5 ∪ 13⋄7 ∪ 13⋄9)->     ;b = 11⋄2->     ;c' = c (11⋄4 ∪ 11⋄8)->     ;d = 13⋄9->     ;e = 13⋄0 ∪ 13⋄1 ∪ 13⋄6->     ;f = (a ∩ b) ∪ (c' ∩ d) ∪ e}-> in buildn 13 f == [0,1,2,6,9,13,14,19,22,24,26,27,32]+> let a = c (13⋄3 ∪ 13⋄5 ∪ 13⋄7 ∪ 13⋄9)+> let b = 11⋄2+> let c' = c (11⋄4 ∪ 11⋄8)+> let d = 13⋄9+> let e = 13⋄0 ∪ 13⋄1 ∪ 13⋄6+> let f = (a ∩ b) ∪ (c' ∩ d) ∪ e+> buildn 13 f == [0,1,2,6,9,13,14,19,22,24,26,27,32]  > differentiate [0,1,2,6,9,13,14,19,22,24,26,27,32] == [1,1,4,3,4,1,5,3,2,2,1,5] -> import Music.Theory.Pitch+> import Music.Theory.Pitch {- hmt -} -> let {n = [0,1,2,6,9,13,14,19,22,24,26,27,32]->     ;r = "C C𝄲 C♯ D♯ E𝄲 F𝄰 G A𝄲 B C C♯ C𝄰 E"}-> in unwords (map (pitch_class_pp . pc24et_to_pitch . (`mod` 24)) n) == r+> let n = [0,1,2,6,9,13,14,19,22,24,26,27,32]+> let r = "C C𝄲 C♯ D♯ E𝄲 F𝄰 G A𝄲 B C C♯ C𝄰 E"+> unwords (map (pitch_class_pp . pc24et_to_pitch . (`mod` 24)) n) == r  Jonchaies  > let s = map (17⋄) [0,1,4,5,7,11,12,16]-> in differentiate (buildn 25 (union s))+> let r = [1,3,1,2,4,1,4,1,1,3,1,2,4,1,4,1,1,3,1,2,4,1,4,1]+> differentiate (buildn 25 (union s)) == r+> let a2 = octpc_to_midi (2,9)+> let m = scanl (+) a2 r+> import Music.Theory.Pitch.Spelling.Table {- hmt -}+> let p = "A2 A#2 C#3 D3 E3 G#3 A3 C#4 D4 D#4 F#4 G4 A4 C#5 D5 F#5 G5 G#5 B5 C6 D6 F#6 G6 B6 C7"+> unwords (map (pitch_pp_iso . midi_to_pitch pc_spell_sharp) m) == p  Nekuïa -> let s = [24⋄0,14⋄2,22⋄3,31⋄4,28⋄7,29⋄9,19⋄10,25⋄13,24⋄14,26⋄17,23⋄21->         ,24⋄10,30⋄9,35⋄17,29⋄24,32⋄25,30⋄29,26⋄21,30⋄17,31⋄16]-> in differentiate (buildn 24 (union s))+> let s = [24⋄0,14⋄2,22⋄3,31⋄4,28⋄7,29⋄9,19⋄10,25⋄13,24⋄14,26⋄17,23⋄21,24⋄10,30⋄9,35⋄17,29⋄24,32⋄25,30⋄29,26⋄21,30⋄17,31⋄16]+> let r = [2,1,1,3,2,1,3,1,2,1,4,3,1,4,1,4,1,3,1,4,1,3,1,4,1,4,1,1,3,1,3,1,2,3,1,4,1,4,4,1]+> differentiate (buildn 41 (union s)) == r+> let a0 = octpc_to_midi (0,9)+> let m = scanl (+) a0 r+> import Music.Theory.Pitch.Spelling.Table {- hmt -}+> let p = "A0 B0 C1 C#1 E1 F#1 G1 A#1 B1 C#2 D2 F#2 A2 A#2 D3 D#3 G3 G#3 B3 C4 E4 F4 G#4 A4 C#5 D5 F#5 G5 G#5 B5 C6 D#6 E6 F#6 A6 A#6 D7 D#7 G7 B7 C8"+> unwords (map (pitch_pp_iso . midi_to_pitch pc_spell_sharp) m) == p +> let s = [8⋄0∩3⋄0,2⋄0∩7⋄2,2⋄1∩11⋄3,31⋄4,4⋄3∩7⋄0,29⋄9,19⋄10,25⋄13,8⋄6∩3⋄2,2⋄1∩13⋄4,23⋄21,8⋄2∩3⋄1,2⋄1∩3⋄0∩5⋄4,5⋄2∩7⋄3,29⋄24,32⋄25,2⋄1∩3⋄2∩5⋄4,2⋄1∩13⋄8,2⋄1∩3⋄2∩5⋄2,31⋄16]+> differentiate (buildn 41 (union s)) == r+ Major scale:  > let s = (c(3⋄2) ∩ 4⋄0) ∪ (c(3⋄1) ∩ 4⋄1) ∪ (3⋄2 ∩ 4⋄2) ∪ (c(3⋄0) ∩ 4⋄3)-> in buildn 7 s == [0,2,4,5,7,9,11]+> buildn 7 s == [0,2,4,5,7,9,11]  Nomos Alpha: -let {s = (c (13⋄3 ∪ 13⋄5 ∪ 13⋄7 ∪ 13⋄9) ∩ 11⋄2) ∪ (c (11⋄4 ∪ 11⋄8) ∩ 13⋄9) ∪ (13⋄0 ∪ 13⋄1 ∪ 13⋄6)-    ;r = [0,1,2,6,9,13,14,19,22,24,26,27,32,35,39,40,45,52,53,58,61,65,66,71,78,79,84,87,90,91,92,97]}-in buildn 32 s == r--/Psappha/ (Flint):--> let {s = union [(8⋄0∪8⋄1∪8⋄7)∩(5⋄1∪5⋄3)->                ,(8⋄0∪8⋄1∪8⋄2)∩5⋄0->                ,8⋄3∩(5⋄0∪5⋄1∪5⋄2∪5⋄3∪5⋄4)->                ,8⋄4∩(5⋄0∪5⋄1∪5⋄2∪5⋄3∪5⋄4)->                ,(8⋄5∪8⋄6)∩(5⋄2∪5⋄3∪5⋄4)->                ,8⋄1∩5⋄2->                ,8⋄6∩5⋄1]->     ;r = [0,1,3,4,6,8,10,11,12->          ,13,14,16,17,19,20,22,23,25->          ,27,28,29,31,33,35,36,37,38]}-> in buildn 27 s == r--À R. (Hommage à Maurice Ravel) (Squibbs, 1996)--> let {s = union [8⋄0∩(11⋄0∪11⋄4∪11⋄5∪11⋄6∪11⋄10)->                ,8⋄1∩(11⋄2∪11⋄3∪11⋄6∪11⋄7∪11⋄9)->                ,8⋄2∩(11⋄0∪11⋄1∪11⋄2∪11⋄3∪11⋄5∪11⋄10)->                ,8⋄3∩(11⋄1∪11⋄2∪11⋄3∪11⋄4∪11⋄10)->                ,8⋄4∩(11⋄0∪11⋄4∪11⋄8)->                ,8⋄5∩(11⋄0∪11⋄2∪11⋄3∪11⋄7∪11⋄9∪11⋄10)->                ,8⋄6∩(11⋄1∪11⋄3∪11⋄5∪11⋄7∪11⋄8∪11⋄9)->                ,8⋄7∩(11⋄1∪11⋄3∪11⋄6∪11⋄7∪11⋄8∪11⋄10)]->     ;r = [0,2,3,4,7,9,10,13,14,16->          ,17,21,23,25,29,30,32,34,35,38->          ,39,43,44,47,48,52,53,57,58,59->          ,62,63,66,67,69,72,73,77,78,82->          ,86,87]}-> in buildn 42 s == r+let s = (c (13⋄3 ∪ 13⋄5 ∪ 13⋄7 ∪ 13⋄9) ∩ 11⋄2) ∪ (c (11⋄4 ∪ 11⋄8) ∩ 13⋄9) ∪ (13⋄0 ∪ 13⋄1 ∪ 13⋄6)+let r = [0,1,2,6,9,13,14,19,22,24,26,27,32,35,39,40,45,52,53,58,61,65,66,71,78,79,84,87,90,91,92,97]+buildn 32 s == r  -}-buildn :: Int -> Sieve -> [I]+buildn :: Int -> Sieve -> [Integer] buildn n = take n . build . reduce --- | Standard differentiation function.------ > differentiate [1,3,6,10] == [2,3,4]--- > differentiate [0,2,4,5,7,9,11,12] == [2,2,1,2,2,2,1]+{- | Standard differentiation function.++> differentiate [1,3,6,10] == [2,3,4]+> differentiate [0,2,4,5,7,9,11,12] == [2,2,1,2,2,2,1]+-} differentiate :: (Num a) => [a] -> [a] differentiate x = zipWith (-) (tail x) x --- | Euclid's algorithm for computing the greatest common divisor.------ > euclid 1989 867 == 51+{- | Euclid's algorithm for computing the greatest common divisor.++> euclid 1989 867 == 51+-} euclid :: (Integral a) => a -> a -> a euclid i j =     let k = i `mod` j     in if k == 0 then j else euclid j k --- | Bachet De Méziriac's algorithm.------ > de_meziriac 15 4 == 3 && euclid 15 4 == 1+{- | Bachet De Méziriac's algorithm.++> de_meziriac 15 4 == 3 && euclid 15 4 == 1+-} de_meziriac :: (Integral a) => a -> a -> a de_meziriac i j =     let f t = if (t * i) `mod` j /= 1@@ -255,12 +246,12 @@               else t     in if j == 1 then 1 else f 1 --- | Attempt to reduce the 'Intersection' of two 'L' nodes to a--- singular 'L' node.------ > reduce_intersection (3,2) (4,7) == Just (12,11)--- > reduce_intersection (12,11) (6,11) == Just (12,11)--- > reduce_intersection (12,11) (8,7) == Just (24,23)+{- | Attempt to reduce the 'Intersection' of two 'L' nodes to a singular 'L' node.++> reduce_intersection (3,2) (4,7) == Just (12,11)+> reduce_intersection (12,11) (6,11) == Just (12,11)+> reduce_intersection (12,11) (8,7) == Just (24,23)+-} reduce_intersection :: (Integral t) => (t,t) -> (t,t) -> Maybe (t,t) reduce_intersection (m1,i1) (m2,i2) =     let d = euclid m1 m2@@ -275,20 +266,21 @@        then Nothing        else Just (m3,i3) --- | Reduce the number of nodes at a 'Sieve'.------ > reduce (L (3,2) ∪ Empty) == L (3,2)--- > reduce (L (3,2) ∩ Empty) == L (3,2)--- > reduce (L (3,2) ∩ L (4,7)) == L (12,11)--- > reduce (L (6,9) ∩ L (15,18)) == L (30,3)------ > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19--- > in reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70)------ > putStrLn $ sieve_pp (reduce s)------ > let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19--- > in reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70)+{- | Reduce the number of nodes at a 'Sieve'.++> reduce (L (3,2) ∪ Empty) == L (3,2)+> reduce (L (3,2) ∩ Empty) == L (3,2)+> reduce (L (3,2) ∩ L (4,7)) == L (12,11)+> reduce (L (6,9) ∩ L (15,18)) == L (30,3)++> let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19+> reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70)++> putStrLn $ sieve_pp (reduce s)++> let s = 3⋄2∩4⋄7∩6⋄11∩8⋄7 ∪ 6⋄9∩15⋄18 ∪ 13⋄5∩8⋄6∩4⋄2 ∪ 6⋄9∩15⋄19+> reduce s == (24⋄23 ∪ 30⋄3 ∪ 104⋄70)+-} reduce :: Sieve -> Sieve reduce s =     let f g s1 s2 =@@ -307,3 +299,43 @@          Intersection (L p) (L q) -> maybe Empty L (reduce_intersection p q)          Intersection s1 s2 -> f Intersection s1 s2          Complement s' -> Complement (reduce s')++-- * Literature++psappha_flint_c :: [Sieve]+psappha_flint_c =+  let s0 = (8⋄0∪8⋄1∪8⋄7)∩(5⋄1∪5⋄3)+      s1 = (8⋄0∪8⋄1∪8⋄2)∩5⋄0+      s2 = 8⋄3∩(5⋄0∪5⋄1∪5⋄2∪5⋄3∪5⋄4)+      s3 = 8⋄4∩(5⋄0∪5⋄1∪5⋄2∪5⋄3∪5⋄4)+      s4 = (8⋄5∪8⋄6)∩(5⋄2∪5⋄3∪5⋄4)+      s5 = 8⋄1∩5⋄2+      s6 = 8⋄6∩5⋄1+  in [s0, s1, s2, s3, s4, s5, s6]++{- | /Psappha/ (Flint)++> let r = [0,1,3,4,6,8,10,11,12,13,14,16,17,19,20,22,23,25,27,28,29,31,33,35,36,37,38]+> buildn 27 psappha_flint == r+-}+psappha_flint :: Sieve+psappha_flint = union psappha_flint_c++a_r_squibbs_c :: [Sieve]+a_r_squibbs_c =+  [8⋄0∩(11⋄0∪11⋄4∪11⋄5∪11⋄6∪11⋄10)+  ,8⋄1∩(11⋄2∪11⋄3∪11⋄6∪11⋄7∪11⋄9)+  ,8⋄2∩(11⋄0∪11⋄1∪11⋄2∪11⋄3∪11⋄5∪11⋄10)+  ,8⋄3∩(11⋄1∪11⋄2∪11⋄3∪11⋄4∪11⋄10)+  ,8⋄4∩(11⋄0∪11⋄4∪11⋄8)+  ,8⋄5∩(11⋄0∪11⋄2∪11⋄3∪11⋄7∪11⋄9∪11⋄10)+  ,8⋄6∩(11⋄1∪11⋄3∪11⋄5∪11⋄7∪11⋄8∪11⋄9)+  ,8⋄7∩(11⋄1∪11⋄3∪11⋄6∪11⋄7∪11⋄8∪11⋄10)]++{- | À R. (Hommage à Maurice Ravel) (Squibbs, 1996)++let r = [0,2,3,4,7,9,10,13,14,16,17,21,23,25,29,30,32,34,35,38,39,43,44,47,48,52,53,57,58,59,62,63,66,67,69,72,73,77,78,82,86,87]+buildn 42 a_r_squibbs == r+-}+a_r_squibbs :: Sieve+a_r_squibbs = union a_r_squibbs_c
Music/Theory/Z.hs view
@@ -9,7 +9,7 @@ -- | Z type. -- -- > map z_modulus [z7,z12] == [7,12]-data Z i = Z {z_modulus :: i}+newtype Z i = Z {z_modulus :: i}  -- | 'mod' of 'Z'. --@@ -81,7 +81,7 @@ to_Z z = z_fromInteger z . fromIntegral  from_Z :: (Integral i,Num n) => i -> n-from_Z i = fromIntegral i+from_Z = fromIntegral  -- | Universe of 'Z'. --@@ -115,7 +115,7 @@ 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+z_toInteger = to_Z  -- * Z16
Music/Theory/Z/Boros_1990.hs view
@@ -15,15 +15,15 @@ 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+import qualified Music.Theory.Graph.Fgl as T import qualified Music.Theory.List as T import qualified Music.Theory.Set.List as T import qualified Music.Theory.Tuple as T import qualified Music.Theory.Z as T import qualified Music.Theory.Z.Forte_1973 as T-import qualified Music.Theory.Z.TTO as T+import qualified Music.Theory.Z.Tto as T --- * UTIL+-- * Util  singular :: String -> [t] -> t singular err l =@@ -37,9 +37,9 @@ elem_by :: (t -> t -> Bool) -> t -> [t] -> Bool elem_by f e = any (f e) --- * TTO+-- * Tto -tto_tni_univ :: Integral i => [T.TTO i]+tto_tni_univ :: Integral i => [T.Tto i] tto_tni_univ = filter ((== 1) . T.tto_M) (T.z_tto_univ 5 T.z12)  all_tn :: Integral i => [i] -> [[i]]@@ -51,67 +51,67 @@ uniq_tni :: Integral i => [i] -> [[i]] uniq_tni = nub . all_tni -type PC = Int-type PCSET = [PC]-type SC = PCSET+type Pc = Int+type Pcset = [Pc]+type Sc = Pcset  -- > pcset_trs 3 [0,1,9] == [0,3,4]-pcset_trs :: Int -> PCSET -> PCSET+pcset_trs :: Int -> Pcset -> Pcset pcset_trs = T.z_tto_tn T.z12  -- | Forte prime forms of the twelve trichordal set classes. -- -- > length trichords == 12-trichords :: [PCSET]+trichords :: [Pcset] 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 :: Pcset -> Bool self_inv p = elem_by set_eq (map (T.z_negate T.z12) p) (all_tn p)  -- | Pretty printer, comma separated. -- -- > pcset_pp [0,3,7,10] == "0,3,7,10"-pcset_pp :: PCSET -> String+pcset_pp :: Pcset -> String pcset_pp = intercalate "," . map show  -- | Pretty printer, hexadecimal, no separator. -- -- > pcset_pp_hex [0,3,7,10] == "037A"-pcset_pp_hex :: PCSET -> String-pcset_pp_hex = map toUpper . concat . map (flip showHex "")+pcset_pp_hex :: Pcset -> String+pcset_pp_hex = map toUpper . concatMap (`showHex` "") --- * ATH+-- * Ath  -- | Forte prime form of the all-trichord hexachord. -- -- > T.sc_name ath == "6-Z17" -- > T.sc "6-Z17" == ath-ath :: PCSET+ath :: Pcset ath = [0,1,2,4,7,8]  -- | Is /p/ an instance of 'ath'.-is_ath :: PCSET -> Bool+is_ath :: Pcset -> Bool is_ath p = T.z_forte_prime T.z12 p == ath  -- | Table 1, p.20 -- -- > length ath_univ == 24-ath_univ :: [PCSET]+ath_univ :: [Pcset] ath_univ = uniq_tni ath --- | Calculate 'T.TTO' of pcset, which must be an instance of 'ath'.+-- | Calculate 'T.Tto' of pcset, which must be an instance of 'ath'. ----- > ath_tni [1,2,3,7,8,11] == T.TTO 3 1 True-ath_tni :: PCSET -> T.TTO PC+-- > 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 ((== 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. -- -- > ath_pp [1,2,3,7,8,11] == "h3"-ath_pp :: PCSET -> String+ath_pp :: Pcset -> String ath_pp p =     let r = ath_tni p         h = if T.tto_I r then 'h' else 'H'@@ -120,51 +120,51 @@ -- | The twenty three-element subsets of 'ath'. -- -- > length ath_trichords == 20-ath_trichords :: [PCSET]+ath_trichords :: [Pcset] ath_trichords = T.combinations (3::Int) ath  -- | '\\' of 'ath' and /p/, ie. the pitch classes that are in 'ath' and not in /p/. -- -- > ath_complement [0,1,2] == [4,7,8]-ath_complement :: PCSET -> PCSET+ath_complement :: Pcset -> Pcset ath_complement p = ath \\ p  -- | /p/ is a pcset, /q/ a sc, calculate pcsets in /q/ that with /p/ form 'ath'. -- -- > ath_completions [0,1,2] (T.sc "3-3") == [[6,7,10],[4,7,8]] -- > ath_completions [6,7,10] (T.sc "3-5") == [[1,2,8]]-ath_completions :: PCSET -> SC -> [PCSET]+ath_completions :: Pcset -> Sc -> [Pcset] ath_completions p q =     let f z = is_ath (p ++ z)     in filter f (uniq_tni q) -realise_ath_seq :: [PCSET] -> [[PCSET]]+realise_ath_seq :: [Pcset] -> [[Pcset]] realise_ath_seq sq =     case sq of       p:q:sq' -> concatMap (\z -> map (p :) (realise_ath_seq (z : sq'))) (ath_completions p q)       _ -> [sq]  -- return edges that connect z to nodes at gr in an ATH relation-ath_gr_extend :: [T.EDGE 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.EDGE PCSET] -> [T.EDGE 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+-- * Tables  -- > length table_3 == 20-table_3 :: [((PCSET,SC,T.SC_Name),(PCSET,SC,T.SC_Name))]+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.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.Text_Table -> [String] pp_tbl = T.table_pp T.table_opt_simple  -- > putStrLn $ unlines $ table_3_md@@ -176,7 +176,7 @@     in pp_tbl (hdr : map f table_3)  -- > length table_4 == 10-table_4 :: [((PCSET,PCSET,T.SC_Name),(PCSET,PCSET,T.SC_Name))]+table_4 :: [((Pcset,Pcset,T.SC_Name),(Pcset,Pcset,T.SC_Name))] table_4 = nub (map T.t2_sort table_3)  -- > putStrLn $ unlines $ table_4_md@@ -187,7 +187,7 @@         hdr = ["Trichords","Prime Forms","Forte Numbers"]     in pp_tbl (hdr : map f table_4) -table_5 :: [(PCSET,Int)]+table_5 :: [(Pcset,Int)] table_5 = T.histogram (map (T.z_forte_prime T.z12) ath_trichords)  -- > putStrLn $ unlines $ table_5_md@@ -196,7 +196,7 @@     let f (p,q) = [pcset_pp_hex p,show q]     in pp_tbl (["SC","#ATH"] : map f table_5) -table_6 :: [(PCSET,Int,Int)]+table_6 :: [(Pcset,Int,Int)] table_6 =     let f (p,n) = (p,n,length (filter (\q -> p `T.is_subset` q) ath_univ))     in map f table_5@@ -207,38 +207,38 @@     let f (p,q,r) = [pcset_pp_hex p,show q,show r]     in pp_tbl (["SC","#H0","#Hn"] : map f table_6) --- * FIGURES+-- * Figures -fig_1 :: [T.EDGE PCSET]+fig_1 :: [T.Edge Pcset] fig_1 = map (T.t2_map T.p3_snd) table_4 -fig_1_gr :: G.Gr PCSET ()+fig_1_gr :: G.Gr Pcset () fig_1_gr = T.g_from_edges fig_1  -- > putStrLn $ unlines $ map (unwords . map pcset_pp) fig_2-fig_2 :: [[PCSET]]+fig_2 :: [[Pcset]] fig_2 =  let g = G.undir fig_1_gr      n = G.labNodes g      n' = filter ((== 2) . G.deg g . fst) n      c = T.combinations (2::Int) n'-     p = map (\[lhs,rhs] -> G.esp (fst lhs) (fst rhs) g) c-     p' = (filter (not . null) p)- in map (mapMaybe (\x -> lookup x n)) p'+     p = map (\l -> let (lhs,rhs) = T.firstSecond l in G.esp (fst lhs) (fst rhs) g) c+     p' = filter (not . null) p+ in map (mapMaybe (`lookup` n)) p' -fig_3 :: [[T.EDGE 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 :: [G.Gr Pcset ()] fig_3_gr = map T.g_from_edges fig_3 -fig_4 :: [[T.EDGE 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.EDGE PCSET]]+fig_5 :: [[T.Edge Pcset]] fig_5 =     let c = [0,4,8]         f gr = case ath_gr_extend gr c of@@ -249,25 +249,25 @@  -- * Drawing -uedge_set :: Ord v => [T.EDGE v] -> [T.EDGE v]+uedge_set :: Ord v => [T.Edge v] -> [T.Edge v] uedge_set = nub . map T.t2_sort  -- | Self-inversional pcsets are drawn in a double circle, other pcsets in a circle.-set_shape :: PCSET -> T.DOT_ATTR+set_shape :: Pcset -> T.Dot_Attr set_shape v = ("shape",if self_inv v then "doublecircle" else "circle") -type GR = G.Gr PCSET ()+type Gr = G.Gr Pcset () -gr_pp' :: (PCSET -> String) -> T.GR_PP PCSET ()+gr_pp' :: (Pcset -> String) -> T.Graph_Pp Pcset () gr_pp' f = (\(_,v) -> [set_shape v,("label",f v)],const []) -gr_pp :: T.GR_PP PCSET ()+gr_pp :: T.Graph_Pp Pcset () gr_pp = gr_pp' pcset_pp  d_fig_1 :: [String] d_fig_1 = T.fgl_to_udot [] gr_pp fig_1_gr -d_fig_3_g :: GR+d_fig_3_g :: Gr d_fig_3_g = T.g_from_edges (uedge_set (concat fig_3))  d_fig_3 :: [String]@@ -276,25 +276,25 @@ d_fig_3' :: [[String]] 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 :: Gr d_fig_4_g = T.g_from_edges (uedge_set (concat fig_4))  d_fig_4 :: [String] d_fig_4 = T.fgl_to_udot [] gr_pp d_fig_4_g -d_fig_5_g :: GR+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.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 :: [T.Edge_Lbl Pcset Pcset] d_fig_5_e = map (\(p,q) -> ((p,q),p++q)) (uedge_set (concat fig_5)) -d_fig_5_g' :: G.Gr PCSET PCSET+d_fig_5_g' :: G.Gr Pcset Pcset d_fig_5_g' = T.g_from_edges_l d_fig_5_e  d_fig_5' :: [String] d_fig_5' =-    let pp = (\_ -> [("shape","")],\(_,e) -> [("label",ath_pp e)])+    let pp = (const [("shape","")],\(_,e) -> [("label",ath_pp e)])     in T.fgl_to_udot [("node:shape","point"),("edge:len","1.25")] pp d_fig_5_g'
Music/Theory/Z/Castren_1994.hs view
@@ -11,7 +11,7 @@ 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+import qualified Music.Theory.Z.Sro as Sro  type Z12 = Int8 @@ -20,7 +20,7 @@ -- > 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]+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'. --@@ -30,7 +30,7 @@ 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))+    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@@ -80,7 +80,7 @@ -- > t_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4]] -- > t_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6]] t_subsets :: [Z12] -> [Z12] -> [[Z12]]-t_subsets x a = filter (`List.is_subset` x) (map sort (SRO.z_sro_t_related z12 a))+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/. --@@ -88,7 +88,7 @@ -- > ti_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4],[0,3,4]] -- > ti_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6],[3,6,7]] ti_subsets :: [Z12] -> [Z12] -> [[Z12]]-ti_subsets x a = filter (`List.is_subset` x) (nub (map sort (SRO.z_sro_ti_related z12 a)))+ti_subsets x a = filter (`List.is_subset` x) (nub (map sort (Sro.z_sro_ti_related z12 a)))  -- | Trivial run length encoder. --
Music/Theory/Z/Clough_1979.hs view
@@ -13,7 +13,7 @@ transpose_to_zero p =     case p of       [] -> []-      n:_ -> map (+ (negate n)) p+      n:_ -> map (subtract n) p  -- | Diatonic pitch class (Z7) set to /chord/. --
Music/Theory/Z/Drape_1999.hs view
@@ -11,8 +11,8 @@ 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+import Music.Theory.Z.Sro+import Music.Theory.Z.Tto  -- | Cardinality filter --@@ -145,7 +145,7 @@ 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)+    in concatMap (is !!)  -- | Degree of intersection. --@@ -218,7 +218,7 @@ -} frg_pp :: Integral i => [i] -> String frg_pp =-    let f = unwords . map (\p -> T.bracket ('[',']') p)+    let f = unwords . map (T.bracket ('[',']'))         g x y = x ++ ": " ++ y     in unlines . zipWith g frg_hdr . T.t6_to_list . T.t6_map f . frg @@ -310,7 +310,7 @@ 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+        f = any (\x -> z_forte_prime z12 (nub (p ++ x)) == q) . z_tto_ti_related z12     in map sc_name (filter f (cf [k] scs))  -- | Matrix search.@@ -360,7 +360,7 @@ > 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 :: Integral t => t -> Z t -> [t] -> [t] -> [Tto t] rs m z p q = z_tto_rel m z (T.set p) (T.set q)  {- | Relate segments.@@ -381,15 +381,15 @@ > 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 z o x == y) (z_sro_univ (length x) m z)+rsg :: Integral i => i -> Z i -> [i] -> [i] -> [Sro i]+rsg = z_sro_rel  -- | 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)+    let f p = all (\q -> has_sc z q p) xs     in filter f scs  {- | scc = set class completion@@ -416,24 +416,24 @@     ,"complement"     ,"multiplication-by-five-transform"] --- | (PCSET,TTO,FORTE-PRIME)-type SI i = ([i],TTO i,[i])+-- | (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 [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+                       x_o = head (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 [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) =@@ -516,13 +516,13 @@ >>> 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]+> 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]+> sro (Z.Sro 0 False 4 False True) [1,5,6] == [3,11,10]  >>> echo 156 | pct sro T4  | pct sro T0I 732@@ -535,8 +535,8 @@ > 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+sro :: Integral i => Z i -> Sro i -> [i] -> [i]+sro = z_sro_apply  {- | tmatrix
+ Music/Theory/Z/Drape_1999/Cli.hs view
@@ -0,0 +1,111 @@+module Music.Theory.Z.Drape_1999.Cli where++import Data.Char {- base -}+import Data.Int {- base -}++import Music.Theory.Z {- hmt -}+import Music.Theory.Z.Drape_1999 {- hmt -}+import Music.Theory.Z.Forte_1973 {- hmt -}+import Music.Theory.Z.Sro {- hmt -}++type Z12 = Int8++help :: [String]+help =+    ["pct ess pcset"+    ,"pct fl -c cset"+    ,"pct frg pcset"+    ,"pct si [pcset]"+    ,"pct spsc set-class..."+    ,"pct sra"+    ,"pct sro sro"+    ,"pct tmatrix pcseg"+    ,"pct trs [-m] pcseg"]++z16_seq_parse :: String -> [Int]+z16_seq_parse = map digitToInt++pco_parse :: String -> [Z12]+pco_parse = map fromIntegral . z16_seq_parse++pco_pp :: [Z12] -> String+pco_pp = map (toUpper . integral_to_digit)++-- > cset_parse "34" == [3,4]+cset_parse :: String -> [Int]+cset_parse = map digitToInt++type CMD = String -> String++mk_cmd :: ([Z12] -> [Z12]) -> CMD+mk_cmd f = pco_pp . f . pco_parse++mk_cmd_many :: ([Z12] -> [[Z12]]) -> CMD+mk_cmd_many f = unlines . map pco_pp . f . pco_parse++-- > ess_cmd "0164325" "23A" == unlines ["923507A","2B013A9"]+ess_cmd :: String -> CMD+ess_cmd p = mk_cmd_many (ess z12 (pco_parse p))++z12_sc_name :: [Z12] -> SC_Name+z12_sc_name = sc_name++fl_c_cmd :: CMD+fl_c_cmd = unlines . map z12_sc_name . concatMap scs_n . cset_parse++frg_cmd :: CMD+frg_cmd p =+    let p' = pco_parse p+    in unlines [frg_pp p',ic_cycle_vector_pp (ic_cycle_vector p')]++pi_cmd :: String -> CMD+pi_cmd p = mk_cmd_many (pci z12 (z16_seq_parse p))++scc_cmd :: String -> CMD+scc_cmd p = mk_cmd_many (scc z12 (sc p))++si_cmd :: CMD+si_cmd = unlines . si . pco_parse++z12_sc_name_long :: [Z12] -> SC_Name+z12_sc_name_long = sc_name_long++-- > spsc_cmd ["4-11","4-12"] == "5-26[02458]\n"+spsc_cmd :: [String] -> String+spsc_cmd = unlines . map z12_sc_name_long . spsc z12 . map sc++sra_cmd :: CMD+sra_cmd = mk_cmd_many (sra z12)++sro_cmd :: String -> CMD+sro_cmd o = mk_cmd (sro z12 (sro_parse 5 o))++-- > putStrLn $ tmatrix_cmd "1258"+tmatrix_cmd :: CMD+tmatrix_cmd = mk_cmd_many (tmatrix z12)++-- > putStrLn $ trs_cmd (trs z12) "024579" "642"+trs_cmd :: ([Z12] -> [Z12] -> [[Z12]]) -> String -> CMD+trs_cmd f p = mk_cmd_many (f (pco_parse p))++interact_ln :: CMD -> IO ()+interact_ln f = interact (unlines . map f . lines)++pct_cli :: [String] -> IO ()+pct_cli arg = do+  case arg of+    ["ess",p] -> interact_ln (ess_cmd p)+    ["fl","-c",c] -> putStr (fl_c_cmd c)+    ["frg",p] -> putStr (frg_cmd p)+    ["pi",p,q] -> putStr (pi_cmd q p)+    ["scc",p] -> interact_ln (scc_cmd p)+    ["scc",p,q] -> putStr (scc_cmd p q)+    ["si"] -> interact_ln si_cmd+    ["si",p] -> putStr (si_cmd p)+    "spsc":p -> putStr (spsc_cmd p)+    ["sra"] -> interact_ln sra_cmd+    ["sro",o] -> interact_ln (sro_cmd o)+    ["tmatrix",p] -> putStr (tmatrix_cmd p)+    ["trs",p] -> interact_ln (trs_cmd (trs z12) p)+    ["trs","-m",p] -> interact_ln (trs_cmd (trs_m z12) p)+    _ -> putStrLn (unlines help)
Music/Theory/Z/Forte_1973.hs view
@@ -2,6 +2,7 @@ --   Yale University Press, New Haven, 1973. module Music.Theory.Z.Forte_1973 where +import Data.Bifunctor {- base -} import Data.List {- base -} import Data.Maybe {- base -} @@ -10,7 +11,7 @@  import Music.Theory.Unicode {- hmt -} import Music.Theory.Z {- hmt -}-import Music.Theory.Z.SRO {- hmt -}+import Music.Theory.Z.Sro {- hmt -}  -- * Prime form @@ -55,6 +56,7 @@  > 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]+> z_forte_prime z5 [0,1,1] -- ERROR  > S.set (map (z_forte_prime z5) (S.powerset [0..4])) > S.set (map (z_forte_prime z7) (S.powerset [0..6]))@@ -366,7 +368,7 @@ 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+    in map (first f) sc_table  -- | Lookup name of prime form of set class.  It is an error for the -- input not to be a forte prime form.
Music/Theory/Z/Morris_1974.hs view
@@ -2,13 +2,15 @@ -- /Journal of Music Theory/, 18:364-389, 1974. module Music.Theory.Z.Morris_1974 where +import Control.Monad {- base -}+ import qualified Control.Monad.Logic as L {- logict -} --- | 'L.msum' '.' 'map' 'return'.+-- | 'msum' '.' 'map' 'return'. -- -- > L.observeAll (fromList [1..7]) == [1..7]-fromList :: L.MonadPlus m => [a] -> m a-fromList = L.msum . map return+fromList :: MonadPlus m => [a] -> m a+fromList = msum . map return  -- | Interval from /i/ to /j/ in modulo-/n/. --@@ -21,16 +23,16 @@ -- > 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 :: (MonadPlus 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+                    guard (i `notElem` p)+                    let j = head p                         m = int_n n i j-                    L.guard (m `notElem` q)+                    guard (m `notElem` q)                     recur (k + 1) (i : p) (m : q)     in recur 1 [0] []
Music/Theory/Z/Read_1978.hs view
@@ -11,7 +11,7 @@  import qualified Music.Theory.List as List {- hmt -} import qualified Music.Theory.Z as Z {- hmt -}-import qualified Music.Theory.Z.SRO as SRO {- hmt -}+import qualified Music.Theory.Z.Sro as Sro {- hmt -}  -- | Coding. type Code = Word64@@ -29,7 +29,7 @@  -- | Pretty printer for 'Bit_Array'. bit_array_pp :: Bit_Array -> String-bit_array_pp = map intToDigit . map fromEnum+bit_array_pp = map (intToDigit . fromEnum)  -- | Parse PP of 'Bit_Array'. --@@ -79,7 +79,7 @@ -- | 'bit_array_to_code' of 'set_to_bit_array'. -- -- > set_to_code 12 [0,2,3,5] == 2880--- > map (set_to_code 12) (SRO.z_sro_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 = bit_array_to_code . set_to_bit_array z @@ -92,7 +92,7 @@         p = bit_array_to_set a         n = length a         z = Z.Z n-        u = maximum (map (set_to_code n) (SRO.z_sro_ti_related z p))+        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.@@ -163,6 +163,6 @@ -- > 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+    let t = map (\x -> Sro.z_sro_tn z x s) (Z.z_univ z)+        c = t ++ map (Sro.z_sro_invert z 0) t     in set_decode (fromIntegral (Z.z_modulus z)) (minimum (map set_encode c))
− Music/Theory/Z/SRO.hs 
@@ -1,214 +0,0 @@--- | Serial (ordered) pitch-class operations on 'Z'.-module Music.Theory.Z.SRO where--import Data.List {- base -}--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 :: t -- 1 5-                 ,sro_I :: Bool}-             deriving (Eq,Show)---- | Printer in 'rnRTnMI' form.-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 == 5 then "M" else if m == 1 then "" else error "sro_pp: M?"-           ,if i then "I" else ""]---- | 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' <- Parse.is_char 'R'-  _ <- P.char 'T'-  t <- Parse.parse_int-  m <- Parse.is_char 'M'-  i <- Parse.is_char 'I'-  P.eof-  return (SRO r r' t (if m then m_mul else 1) i)---- | Parse a Morris format serial operator descriptor.------ > 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 m) ""---- * Z---- | The total set of serial operations.------ > 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 <- [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 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 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 1 i |-     r <- [True,False],-     n <- z_univ z,-     i <- [False,True]]---- | 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 <- [1,m_mul],-     i <- [True,False]]---- | The set of retrograde,transposition,@M5@ and inversion 'SRO's.-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 <- [1,m_mul],-     i <- [True,False]]---- * Serial operations---- | Apply SRO.------ > 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 == 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 List.rotate_left r x4---- * PLAIN---- | Transpose /p/ by /n/.------ > 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 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 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 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 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 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 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 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 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-      [] -> []-      x:xs -> n : z_sro_tn z (z_sub z n x) xs---- | Variant of 'invert', inverse about /n/th element.------ > 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 z12 [0,1,3] == [[0,1,3],[11,0,2],[9,10,0]]-z_tmatrix :: Integral i => Z i -> [i] -> [[i]]-z_tmatrix z p = map (\n -> z_sro_tn z n p) (z_sro_tn_to z 0 (z_sro_invert_ix z 0 p))
+ Music/Theory/Z/Sro.hs view
@@ -0,0 +1,219 @@+-- | Serial (ordered) pitch-class operations on 'Z'.+module Music.Theory.Z.Sro where++import Data.List {- base -}++import qualified Text.Parsec 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 :: t -- 1 5+                 ,sro_I :: Bool}+             deriving (Eq,Show)++-- | Printer in 'rnRTnMI' form.+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 == 5 then "M" else if m == 1 then "" else error "sro_pp: M?"+           ,if i then "I" else ""]++-- | Parser for Sro.+p_sro :: Integral t => t -> Parse.P (Sro t)+p_sro m_mul = do+  let rot = P.option 0 (P.char 'r' >> Parse.parse_int)+  r <- rot+  r' <- Parse.is_char 'R'+  _ <- P.char 'T'+  t <- Parse.parse_int+  m <- Parse.is_char 'M'+  i <- Parse.is_char 'I'+  P.eof+  return (Sro r r' t (if m then m_mul else 1) i)++-- | Parse a Morris format serial operator descriptor.+--+-- > 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 m) ""++-- * Z++-- | The total set of serial operations.+--+-- > 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 <- [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 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 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 1 i |+     r <- [True,False],+     n <- z_univ z,+     i <- [False,True]]++-- | 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 <- [1,m_mul],+     i <- [True,False]]++-- | The set of retrograde,transposition,@M5@ and inversion 'Sro's.+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 <- [1,m_mul],+     i <- [True,False]]++-- * Serial operations++-- | Apply Sro.+--+-- > 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 == 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 List.rotate_left r x4++-- | Find 'Sro's that map /x/ to /y/ given /m/ and /z/.+--+-- > map sro_pp (z_sro_rel 5 z12 [0,1,2,3] [11,6,1,4]) == ["r1T4MI","r1RT1M"]+z_sro_rel :: (Ord t,Integral t) => t -> Z t -> [t] -> [t] -> [Sro t]+z_sro_rel m z x y = filter (\o -> z_sro_apply z o x == y) (z_sro_univ (length x) m z)++-- * Plain++-- | Transpose /p/ by /n/.+--+-- > 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 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 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 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 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 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 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 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 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+      [] -> []+      x:xs -> n : z_sro_tn z (z_sub z n x) xs++-- | Variant of 'invert', inverse about /n/th element.+--+-- > 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 z12 [0,1,3] == [[0,1,3],[11,0,2],[9,10,0]]+z_tmatrix :: Integral i => Z i -> [i] -> [[i]]+z_tmatrix z p = map (\n -> z_sro_tn z n p) (z_sro_tn_to z 0 (z_sro_invert_ix z 0 p))
− Music/Theory/Z/TTO.hs 
@@ -1,148 +0,0 @@--- | 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.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 :: t,tto_I :: Bool}-             deriving (Eq,Show)---- | T0-tto_identity :: Num t => TTO t-tto_identity = TTO 0 1 False---- | 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 ""]---- | 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 <- Parse.parse_int-  m <- Parse.is_char 'M'-  i <- Parse.is_char 'I'-  P.eof-  return (TTO t (if m then m_mul else 1) i)---- | Parser, transposition must be decimal.------ > 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) ""---- | 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 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]---- | Apply TTO to pitch-class.------ > 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 == 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---- | 'nub' of 'sort' of 'z_tto_f'.  (nub because M may be 0).------ > 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's that map pc-set /x/ to pc-set /y/ given /m/ and /z/.------ > 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 f o = if z_tto_apply z o x == y then Just o else Nothing-  in mapMaybe f (z_tto_univ m z)---- * PLAIN---- | 'nub' of 'sort' of 'z_mod' of /z/.------ > z_pcset z12 [1,13] == [1]--- > map (z_pcset z12) [[0,6],[6,12],[12,18]] == replicate 3 [0,6]-z_pcset :: (Integral t,Ord t) => Z t -> [t] -> [t]-z_pcset z = nub . sort . map (z_mod z)---- | Transpose by n.------ > z_tto_tn z12 4 [1,5,6] == [5,9,10]--- > z_tto_tn z12 4 [0,4,8] == [0,4,8]-z_tto_tn :: Integral i => Z i -> i -> [i] -> [i]-z_tto_tn z n = sort . map (z_add z n)---- | Invert about n.------ > z_tto_invert z12 6 [4,5,6] == [6,7,8]--- > z_tto_invert z12 0 [0,1,3] == [0,9,11]-z_tto_invert :: Integral i => Z i -> i -> [i] -> [i]-z_tto_invert z n = sort . map (\p -> z_sub z n (z_sub z p n))---- | Composition of 'z_tto_invert' about @0@ and 'z_tto_tn'.------ > z_tto_tni z12 4 [1,5,6] == [3,10,11]--- > (z_tto_invert z12 0 . z_tto_tn z12 4) [1,5,6] == [2,3,7]-z_tto_tni :: Integral i => Z i -> i -> [i] -> [i]-z_tto_tni z n = z_tto_tn z n . z_tto_invert z 0---- | Modulo-z multiplication------ > z_tto_mn z12 11 [0,1,4,9] == z_tto_invert z12 0 [0,1,4,9]-z_tto_mn :: Integral i => Z i -> i -> [i] -> [i]-z_tto_mn z n = sort . map (z_mul z n)---- | M5, ie. 'mn' @5@.------ > z_tto_m5 z12 [0,1,3] == [0,3,5]-z_tto_m5 :: Integral i => Z i -> [i] -> [i]-z_tto_m5 z = z_tto_mn z 5---- * SEQUENCE---- | T-related sets of /p/.-z_tto_t_related_seq :: Integral i => Z i -> [i] -> [[i]]-z_tto_t_related_seq z p = map (\q -> z_tto_tn z q p) [0..11]---- | Unique elements of 'z_tto_t_related_seq'.------ > length (z_tto_t_related z12 [0,1,3]) == 12--- > z_tto_t_related z12 [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]-z_tto_t_related :: Integral i => Z i -> [i] -> [[i]]-z_tto_t_related z = nub . z_tto_t_related_seq z---- | T\/I-related set of /p/.-z_tto_ti_related_seq :: Integral i => Z i -> [i] -> [[i]]-z_tto_ti_related_seq z p = z_tto_t_related z p ++ z_tto_t_related z (z_tto_invert z 0 p)---- | Unique elements of 'z_tto_ti_related_seq'.------ > length (z_tto_ti_related z12 [0,1,3]) == 24--- > z_tto_ti_related z12 [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]]-z_tto_ti_related :: Integral i => Z i -> [i] -> [[i]]-z_tto_ti_related z = nub . z_tto_ti_related_seq z
+ Music/Theory/Z/Tto.hs view
@@ -0,0 +1,147 @@+-- | 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.Parsec 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 :: t,tto_I :: Bool}+             deriving (Eq,Show)++-- | T0+tto_identity :: Num t => Tto t+tto_identity = Tto 0 1 False++-- | 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 ""]++-- | Parser for Tto, requires value for M (ordinarily 5 for 12-tone Tto).+p_tto :: Integral t => t -> Parse.P (Tto t)+p_tto m_mul = do+  _ <- P.char 'T'+  t <- Parse.parse_int+  m <- Parse.is_char 'M'+  i <- Parse.is_char 'I'+  P.eof+  return (Tto t (if m then m_mul else 1) i)++-- | Parser, transposition must be decimal.+--+-- > 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) ""++-- | 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 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]++-- | Apply Tto to pitch-class.+--+-- > 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 == 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++-- | 'nub' of 'sort' of 'z_tto_f'.  (nub because M may be 0).+--+-- > 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's that map pc-set /x/ to pc-set /y/ given /m/ and /z/.+--+-- > 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 f o = if z_tto_apply z o x == y then Just o else Nothing+  in mapMaybe f (z_tto_univ m z)++-- * Plain++-- | 'nub' of 'sort' of 'z_mod' of /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
− README 
@@ -1,21 +0,0 @@-hmt - haskell music theory-----------------------------[haskell](http://haskell.org/) music theory--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)--© [rohan drape](http://rohandrape.net/), 2006-2020, [gpl](http://gnu.org/copyleft/).
+ README.md view
@@ -0,0 +1,26 @@+hmt - haskell music theory+--------------------------++[haskell](http://haskell.org/) music theory++requires:++- [hmt-base](http://rohandrape.net/?t=hmt-base)++related:++- [hmt-diagrams](http://rohandrape.net/?t=hmt-diagrams)+- [hmt-texts](http://rohandrape.net/?t=hmt-texts)++## cli++[csv-midi](http://rohandrape.net/?t=hmt&e=md/csv-midi.md),+[db](http://rohandrape.net/?t=hmt&e=md/db.md),+[gl](http://rohandrape.net/?t=hmt&e=md/gl.md),+[gr-planar](http://rohandrape.net/?t=hmt&e=md/gr-planar.md),+[obj](http://rohandrape.net/?t=hmt&e=md/obj.md),+[pct](http://rohandrape.net/?t=hmt&e=md/pct.md),+[ply](http://rohandrape.net/?t=hmt&e=md/ply.md),+[scala](http://rohandrape.net/?t=hmt&e=md/scala.md)++© [rohan drape](http://rohandrape.net/), 2006-2022, [gpl](http://gnu.org/copyleft/).
hmt.cabal view
@@ -1,118 +1,96 @@+cabal-version:     2.4 Name:              hmt-Version:           0.18+Version:           0.20 Synopsis:          Haskell Music Theory-Description:       Haskell music theory library-License:           GPL+Description:       Haskell library for Music Theory+License:           GPL-3.0-only Category:          Music-Copyright:         Rohan Drape, 2006-2020+Copyright:         Rohan Drape, 2006-2022 Author:            Rohan Drape Maintainer:        rd@rohandrape.net Stability:         Experimental Homepage:          http://rohandrape.net/t/hmt-Tested-With:       GHC == 8.6.5+Tested-With:       GHC == 9.2.4 Build-Type:        Simple-Cabal-Version:     >= 1.10 -Data-files:        README+Data-files:        README.md                    data/csv/mnd/*.csv                    data/dot/euler/*.dot                    data/scl/*.scl  Library-  Build-Depends:   aeson,-                   array,+  Build-Depends:   array,                    base >= 4.9 && < 5,                    bytestring,                    colour,                    containers,+                   data-memocombinators,                    data-ordlist,                    directory,                    fgl,                    filepath,-                   hsc3 == 0.18.*,+                   hmt-base == 0.20.*,                    lazy-csv,                    logict,                    multiset-comb,                    parsec,-                   permutation,                    primes,                    process,                    random,                    safe,                    split,+                   strict,                    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+  Exposed-modules: Music.Theory.Array.Csv.Midi.Cli+                   Music.Theory.Array.Csv.Midi.Mnd+                   Music.Theory.Array.Csv.Midi.Skini                    Music.Theory.Array.Direction-                   Music.Theory.Array.Text-                   Music.Theory.Bits+                   Music.Theory.Array.Square                    Music.Theory.Bjorklund                    Music.Theory.Block_Design.Johnson_2007                    Music.Theory.Braille-                   Music.Theory.Byte                    Music.Theory.Clef-                   Music.Theory.Combinations                    Music.Theory.Contour.Polansky_1992-                   Music.Theory.DB.Common-                   Music.Theory.DB.CSV-                   Music.Theory.DB.JSON-                   Music.Theory.DB.Plain-                   Music.Theory.Directory+                   Music.Theory.Db.Cli+                   Music.Theory.Db.Common+                   Music.Theory.Db.Csv+                   Music.Theory.Db.Plain                    Music.Theory.Duration                    Music.Theory.Duration.Annotation-                   Music.Theory.Duration.CT+                   Music.Theory.Duration.ClickTrack+                   Music.Theory.Duration.Hollos2014                    Music.Theory.Duration.Name                    Music.Theory.Duration.Name.Abbreviation-                   Music.Theory.Duration.RQ-                   Music.Theory.Duration.RQ.Division-                   Music.Theory.Duration.RQ.Tied+                   Music.Theory.Duration.Rq+                   Music.Theory.Duration.Rq.Division+                   Music.Theory.Duration.Rq.Tied                    Music.Theory.Duration.Sequence.Notate                    Music.Theory.Dynamic_Mark-                   Music.Theory.Either-                   Music.Theory.Enum-                   Music.Theory.Function                    Music.Theory.Gamelan                    Music.Theory.Graph.Deacon_1934                    Music.Theory.Graph.Dot-                   Music.Theory.Graph.FGL-                   Music.Theory.Graph.IO+                   Music.Theory.Graph.Fgl                    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                    Music.Theory.Interval.Barlow_1987                    Music.Theory.Interval.Name                    Music.Theory.Interval.Spelling-                   Music.Theory.IO                    Music.Theory.Key-                   Music.Theory.List-                   Music.Theory.Map-                   Music.Theory.Math-                   Music.Theory.Math.Convert-                   Music.Theory.Math.Convert.FX+                   Music.Theory.List.Logic+                   Music.Theory.Math.Convert.Fx                    Music.Theory.Math.Nichomachus-                   Music.Theory.Math.OEIS+                   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@@ -127,35 +105,33 @@                    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-                   Music.Theory.Show-                   Music.Theory.String                    Music.Theory.Tempo_Marking                    Music.Theory.Tiling.Canon                    Music.Theory.Tiling.Johnson_2004                    Music.Theory.Tiling.Johnson_2009                    Music.Theory.Time.Bel1990.R-                   Music.Theory.Time.Duration-                   Music.Theory.Time.Notation+                   Music.Theory.Time.KeyKit+                   Music.Theory.Time.KeyKit.Basic+                   Music.Theory.Time.KeyKit.Parser                    Music.Theory.Time.Seq                    Music.Theory.Time_Signature-                   Music.Theory.Tuple                    Music.Theory.Tuning                    Music.Theory.Tuning.Alves_1997-                   Music.Theory.Tuning.DB-                   Music.Theory.Tuning.DB.Alves-                   Music.Theory.Tuning.DB.Gann-                   Music.Theory.Tuning.DB.Microtonal_Synthesis-                   Music.Theory.Tuning.DB.Riley-                   Music.Theory.Tuning.DB.Werckmeister-                   Music.Theory.Tuning.EFG-                   Music.Theory.Tuning.ET+                   Music.Theory.Tuning.Anamark+                   Music.Theory.Tuning.Db+                   Music.Theory.Tuning.Db.Alves+                   Music.Theory.Tuning.Db.Gann+                   Music.Theory.Tuning.Db.Microtonal_Synthesis+                   Music.Theory.Tuning.Db.Riley+                   Music.Theory.Tuning.Db.Werckmeister+                   Music.Theory.Tuning.Efg+                   Music.Theory.Tuning.Et                    Music.Theory.Tuning.Gann_1993                    Music.Theory.Tuning.Graph.Euler-                   Music.Theory.Tuning.Graph.ISET-                   Music.Theory.Tuning.HS+                   Music.Theory.Tuning.Graph.Iset+                   Music.Theory.Tuning.Hs                    Music.Theory.Tuning.Load                    Music.Theory.Tuning.Meyer_1929                    Music.Theory.Tuning.Midi@@ -166,15 +142,16 @@                    Music.Theory.Tuning.Polansky_1990                    Music.Theory.Tuning.Rosenboom_1979                    Music.Theory.Tuning.Scala+                   Music.Theory.Tuning.Scala.Cli+                   Music.Theory.Tuning.Scala.Functions                    Music.Theory.Tuning.Scala.Interval-                   Music.Theory.Tuning.Scala.KBM+                   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@@ -183,6 +160,7 @@                    Music.Theory.Z.Castren_1994                    Music.Theory.Z.Clough_1979                    Music.Theory.Z.Drape_1999+                   Music.Theory.Z.Drape_1999.Cli                    Music.Theory.Z.Forte_1973                    Music.Theory.Z.Lewin_1980                    Music.Theory.Z.Literature@@ -191,9 +169,9 @@                    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.Z.Tto+                   Music.Theory.Z.Sro  Source-Repository  head-  Type:            darcs-  Location:        http://rohandrape.net/sw/hmt+  Type:            git+  Location:        https://gitlab.com/rd--/hmt