diff --git a/Help/hmt.help.lhs b/Help/hmt.help.lhs deleted file mode 100644 --- a/Help/hmt.help.lhs +++ /dev/null @@ -1,175 +0,0 @@ -# Pct - -> import Control.Arrow {- base -} -> import Data.Function {- base -} -> import Data.List {- base -} -> import Data.Maybe {- base -} -> import Music.Theory.List {- hmt -} -> import Music.Theory.Permutations {- hmt -} -> import Music.Theory.Set.List {- hmt -} -> import Music.Theory.Z12.Drape_1999 {- hmt -} -> import Music.Theory.Z12.Forte_1973 {- hmt -} -> import Music.Theory.Z12.Morris_1987 {- hmt -} -> import Music.Theory.Z12.Morris_1987.Parse {- hmt -} -> import Music.Theory.Z12.SRO {- hmt -} - -This file illustrates equivalent expressions in pct and hmt terms. - - $ pcom pcseg iseg 01549 | pcom iseg icseg | pcom icseg icset - 145 - -> (set . map ic . int) [0,1,5,4,9] == [1,4,5] - - $ pcom pcseg pcset 01549 | pcom pcset sc | pcom sc icv | pcom icv icset - 1345 - -> let icv_icset x = let f x y = if x > 0 then Just y else Nothing -> in catMaybes (zipWith f x [1..6]) -> in (icv_icset . icv . forte_prime) [0,1,5,4,9] == [1,3,4,5] - - $ pg 5-Z17 | bip | sort -u > 5-Z17.bip ; \ - pg 5-Z37 | bip | sort -u > 5-Z37.bip ; \ - comm 5-Z17.bip 5-Z37.bip -1 -2 | wc -l - 16 - -> let f = nub . map bip . permutations . sc -> in length (f "5-Z17" `intersect` f "5-Z37") == 16 - - $ cat ../db.sh - for sc in $(fl -c $1) - do - pg $sc | bip | sort -u > $sc - done - $ sh ../db.sh 4 - $ ls - 4-1 4-12 4-16 4-19 4-21 4-24 4-27 4-4 4-7 4-Z15 - 4-10 4-13 4-17 4-2 4-22 4-25 4-28 4-5 4-8 4-Z29 - 4-11 4-14 4-18 4-20 4-23 4-26 4-3 4-6 4-9 - -> let {s = filter ((== 4) . length) scs -> ;x = map permutations s} -> in zip (map sc_name s) (map (set . (map bip)) x) - - $ cat view.sh - for i in $(fl -c $1 | pg | bip | sort -u) - do - echo $i":" $(grep -l $i * | sort -t '-' +1 -n | tr "\n" " ") - done - $ sh view.sh 4 - 111: 4-1 - 112: 4-1 4-2 4-3 - 113: 4-1 4-3 4-4 4-7 - ... - -> let {n = 4 -> ;s = filter ((== n) . length) scs -> ;x = map permutations s -> ;z = zip (map sc_name s) (map (set . (map bip)) x) -> ;f b (s,bs) = if b `elem` bs then Just s else Nothing -> ;g b = catMaybes (map (f b) z) -> ;a = set (map bip (concat x))} -> in zip a (map g a) - - $ cyc < ~/src/pct/lib/scs | epmq \ - > "in cset 89" "is icset 12" "hasnt icseg 11" | scdb - 7-34 ascending melodic minor collection - 7-35 diatonic collection (d) - 8-28 octotonic collection (Messiaen Mode II) - -> let {cyc xs = xs ++ [head xs] -> ;a = filter (\p -> length p `elem` [8,9]) (map cyc scs) -> ;b = filter (\p -> set (int p) == [1,2]) a -> ;c = filter (\p -> not ([1,1] `isInfixOf` int p)) b} -> in map (sc_name . nub) c == ["7-34","7-35","8-28"] - - $ epmq < ~/src/pct/lib/univ "in cset 6" "in pcset 579t024" \ - > "has sc 5-35" "hasnt sc 2-6" "notin pcset 024579e" - 02579A - -> let {a = cf [6] (powerset [0..11]) -> ;b = filter (is_superset [0,2,4,5,7,9,10]) a -> ;c = filter (`has_sc` (sc "5-35")) b -> ;d = filter (not . (`has_sc` (sc "2-6"))) c -> ;e = filter (not . is_superset [0,2,4,5,7,9,11]) d} -> in e == [[0,2,5,7,9,10]] - - $ echo 156 | sro T0I | sro T4 - 3BA - -> let {i = SRO 0 False 0 False True -> ;t4 = SRO 0 False 4 False False} -> in (sro i >>> sro t4) [1,5,6] == [3,11,10] - - $ echo 156 | sro T4 | sro T0I - 732 - -> let {i = SRO 0 False 0 False True -> ;t4 = SRO 0 False 4 False False} -> in (sro i . sro t4) [1,5,6] == [7,3,2] - -Note that pct uses right rotation rotation. - -> sro (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4] -> sro (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4] - - I = MB; TnI = TnMB, - -> mn 11 [0,1,4,9] == tni 0 [0,1,4,9] - - MI = IM = M7 = MBM5; TnMI = TnM7 - -> sro (rnrtnmi "T0MI") [0,1,4,9] == mn 7 [0,1,4,9] - - T0 = T0M1; Tn = TnM1 - M = M5; TnM = TnM5, - - $ se -c5 123 - 12333 - 12233 - 12223 - 11233 - 11223 - 11123 - -> expand_set 5 [1,2,3] - -> ici [1,2,3] -> cgg [[0],[1,11],[2,10],[3,9],[4,8],[5,7],[6]] - - $ se -c5 1245 | pg | ici | pcom iseg sc | \ - sort -u | epmq "in cset 6" | wc -l - 42 - -> let {a = expand_set 5 [1,2,4,5] -> ;b = concatMap permutations a -> ;c = concatMap ici b -> ;d = map (forte_prime . dx_d 0) c -> ;e = nub d -> ;f = cf [6] e} -> in length f == 42 - - $ imb -c34 024579 | pfmt - 024 245 457 579 - 0245 2457 4579 - -> imb [3,4] [0,2,4,5,7,9] - - $ rs 0123 e614 - T1M - $ rs 0123 641e416 - T1M - - $ sb 6-32 6-8 | fn | pfmt - 1-1 - 2-1 2-2 2-3 2-4 2-5 - 3-2 3-4 3-6 3-7 3-9 3-11 - 4-10 4-11 4-14 4-22 4-23 - 5-23 - $ for i in `cat ~/src/pct/lib/scs | cf 6 | fn` ; \ - do echo $i >> LIST ; sb $i | cf 3 | wc -l >> LIST ; done - -> map sc_name (sb [sc "6-32",sc "6-8"]) - -> let f p = let xs = cf [3] (sb [p]) -> in (sc_name p,length xs) -> in map f (cf [6] scs) diff --git a/Music/Theory/Array/CSV.hs b/Music/Theory/Array/CSV.hs deleted file mode 100644 --- a/Music/Theory/Array/CSV.hs +++ /dev/null @@ -1,346 +0,0 @@ --- | Regular matrix array data, CSV, column & row indexing. -module Music.Theory.Array.CSV where - -import Data.Array {- array -} -import Data.Char {- base -} -import Data.Function {- base -} -import Data.List {- base -} -import Data.String {- base -} - -import qualified Text.CSV.Lazy.String as C {- lazy-csv -} - -import qualified Music.Theory.List as T {- hmt -} - --- * Indexing - --- | @A@ indexed case-insensitive column references. The column --- following @Z@ is @AA@. -data Column_Ref = Column_Ref {column_ref_string :: String} - -instance IsString Column_Ref where fromString = Column_Ref -instance Read Column_Ref where readsPrec _ s = [(Column_Ref s,[])] -instance Show Column_Ref where show = column_ref_string -instance Eq Column_Ref where (==) = (==) `on` column_index -instance Ord Column_Ref where compare = compare `on` column_index - -instance Enum Column_Ref where - fromEnum = column_index - toEnum = column_ref - -instance Ix Column_Ref where - range = column_range - index = interior_column_index - inRange = column_in_range - rangeSize = column_range_size - --- | Inclusive range of column references. -type Column_Range = (Column_Ref,Column_Ref) - --- | @1@-indexed row reference. -type Row_Ref = Int - --- | Zero index of 'Row_Ref'. -row_index :: Row_Ref -> Int -row_index r = r - 1 - --- | Inclusive range of row references. -type Row_Range = (Row_Ref,Row_Ref) - --- | Cell reference, column then row. -type Cell_Ref = (Column_Ref,Row_Ref) - --- | Inclusive range of cell references. -type Cell_Range = (Cell_Ref,Cell_Ref) - --- | Case folding letter to index function. Only valid for ASCII letters. --- --- > map letter_index ['A' .. 'Z'] == [0 .. 25] --- > map letter_index ['a','d' .. 'm'] == [0,3 .. 12] -letter_index :: Char -> Int -letter_index c = fromEnum (toUpper c) - fromEnum 'A' - --- | Inverse of 'letter_index'. --- --- > map index_letter [0,3 .. 12] == ['A','D' .. 'M'] -index_letter :: Int -> Char -index_letter i = toEnum (i + fromEnum 'A') - --- | Translate column reference to @0@-index. --- --- > :set -XOverloadedStrings --- > map column_index ["A","c","z","ac","XYZ"] == [0,2,25,28,17575] -column_index :: Column_Ref -> Int -column_index (Column_Ref c) = - let m = iterate (* 26) 1 - i = reverse (map letter_index c) - in sum (zipWith (*) m (zipWith (+) [0..] i)) - --- | Column reference to interior index within specified range. Type --- specialised 'Data.Ix.index'. --- --- > map (Data.Ix.index ('A','Z')) ['A','C','Z'] == [0,2,25] --- > map (interior_column_index ("A","Z")) ["A","C","Z"] == [0,2,25] --- --- > map (Data.Ix.index ('B','C')) ['B','C'] == [0,1] --- > map (interior_column_index ("B","C")) ["B","C"] == [0,1] -interior_column_index :: Column_Range -> Column_Ref -> Int -interior_column_index (l,r) c = - let n = column_index c - l' = column_index l - r' = column_index r - in if n > r' - then error (show ("interior_column_index",l,r,c)) - else n - l' - --- | Inverse of 'column_index'. --- --- > let c = ["A","Z","AA","AZ","BA","BZ","CA"] --- > in map column_ref [0,25,26,51,52,77,78] == c --- --- > column_ref (0+25+1+25+1+25+1) == "CA" -column_ref :: Int -> Column_Ref -column_ref = - let rec n = case n `quotRem` 26 of - (0,r) -> [index_letter r] - (q,r) -> index_letter (q - 1) : rec r - in Column_Ref . rec - --- | Type specialised 'pred'. --- --- > column_ref_pred "DF" == "DE" -column_ref_pred :: Column_Ref -> Column_Ref -column_ref_pred = pred - --- | Type specialised 'succ'. --- --- > column_ref_succ "DE" == "DF" -column_ref_succ :: Column_Ref -> Column_Ref -column_ref_succ = succ - --- | Bimap of 'column_index'. --- --- > column_indices ("b","p") == (1,15) --- > column_indices ("B","IT") == (1,253) -column_indices :: Column_Range -> (Int,Int) -column_indices = - let bimap f (i,j) = (f i,f j) - in bimap column_index - --- | Type specialised 'Data.Ix.range'. --- --- > column_range ("L","R") == ["L","M","N","O","P","Q","R"] --- > Data.Ix.range ('L','R') == "LMNOPQR" -column_range :: Column_Range -> [Column_Ref] -column_range rng = - let (l,r) = column_indices rng - in map column_ref [l .. r] - --- | Type specialised 'Data.Ix.inRange'. --- --- > map (column_in_range ("L","R")) ["A","N","Z"] == [False,True,False] --- > map (column_in_range ("L","R")) ["L","N","R"] == [True,True,True] --- --- > map (Data.Ix.inRange ('L','R')) ['A','N','Z'] == [False,True,False] --- > map (Data.Ix.inRange ('L','R')) ['L','N','R'] == [True,True,True] -column_in_range :: Column_Range -> Column_Ref -> Bool -column_in_range rng c = - let (l,r) = column_indices rng - k = column_index c - in k >= l && k <= r - --- | Type specialised 'Data.Ix.rangeSize'. --- --- > map column_range_size [("A","Z"),("AA","ZZ")] == [26,26 * 26] --- > Data.Ix.rangeSize ('A','Z') == 26 -column_range_size :: Column_Range -> Int -column_range_size = (+ 1) . negate . uncurry (-) . column_indices - --- | Type specialised 'Data.Ix.range'. -row_range :: Row_Range -> [Row_Ref] -row_range = range - --- | The standard uppermost leftmost cell reference, @A1@. --- --- > Just cell_ref_minima == parse_cell_ref "A1" -cell_ref_minima :: Cell_Ref -cell_ref_minima = (Column_Ref "A",1) - --- | Cell reference parser for standard notation of (column,row). --- --- > parse_cell_ref "CC348" == Just ("CC",348) -parse_cell_ref :: String -> Maybe Cell_Ref -parse_cell_ref s = - case span isUpper s of - ([],_) -> Nothing - (c,r) -> case span isDigit r of - (n,[]) -> Just (Column_Ref c,read n) - _ -> Nothing - --- | Cell reference pretty printer. --- --- > cell_ref_pp ("CC",348) == "CC348" -cell_ref_pp :: Cell_Ref -> String -cell_ref_pp (Column_Ref c,r) = c ++ show r - --- | Translate cell reference to @0@-indexed pair. --- --- > cell_index ("CC",348) == (80,347) --- > Data.Ix.index (("AA",1),("ZZ",999)) ("CC",348) == 54293 -cell_index :: Cell_Ref -> (Int,Int) -cell_index (c,r) = (column_index c,row_index r) - --- | Type specialised 'Data.Ix.range', cells are in column-order. --- --- > cell_range (("AA",1),("AC",1)) == [("AA",1),("AB",1),("AC",1)] --- --- > let r = [("AA",1),("AA",2),("AB",1),("AB",2),("AC",1),("AC",2)] --- > in cell_range (("AA",1),("AC",2)) == r --- --- > Data.Ix.range (('A',1),('C',1)) == [('A',1),('B',1),('C',1)] --- --- > let r = [('A',1),('A',2),('B',1),('B',2),('C',1),('C',2)] --- > in Data.Ix.range (('A',1),('C',2)) == r -cell_range :: Cell_Range -> [Cell_Ref] -cell_range ((c1,r1),(c2,r2)) = - [(c,r) | - c <- column_range (c1,c2) - ,r <- row_range (r1,r2)] - --- | Variant of 'cell_range' in row-order. --- --- > let r = [(AA,1),(AB,1),(AC,1),(AA,2),(AB,2),(AC,2)] --- > in cell_range_row_order (("AA",1),("AC",2)) == r -cell_range_row_order :: Cell_Range -> [Cell_Ref] -cell_range_row_order ((c1,r1),(c2,r2)) = - [(c,r) | - r <- row_range (r1,r2) - ,c <- column_range (c1,c2)] - --- * TABLE - --- | When reading a CSV file is the first row a header? -type CSV_Has_Header = Bool - -type CSV_Delimiter = Char - -type CSV_Allow_Linebreaks = Bool - --- | When writing a CSV file should the delimiters be aligned, --- ie. should columns be padded with spaces, and if so at which side --- of the data? -data CSV_Align_Columns = CSV_No_Align | CSV_Align_Left | CSV_Align_Right - --- | CSV options. -type CSV_Opt = (CSV_Has_Header,CSV_Delimiter,CSV_Allow_Linebreaks,CSV_Align_Columns) - --- | Default CSV options, no header, comma delimiter, no linebreaks, no alignment. -def_csv_opt :: CSV_Opt -def_csv_opt = (False,',',False,CSV_No_Align) - --- | Plain list representation of a two-dimensional table of /a/ in --- row-order. Tables are regular, ie. all rows have equal numbers of --- columns. -type Table a = [[a]] - --- | CSV table, ie. a table with perhaps a header. -type CSV_Table a = (Maybe [String],Table a) - --- | Read 'Table' from @CSV@ file. -csv_table_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (CSV_Table a) -csv_table_read (hdr,delim,brk,_) f fn = do - s <- readFile fn - let t = C.csvTable (C.parseDSV brk delim s) - p = C.fromCSVTable t - (h,d) = if hdr then (Just (head p),tail p) else (Nothing,p) - return (h,map (map f) d) - --- | Read 'Table' only with 'def_csv_opt'. -csv_table_read' :: (String -> a) -> FilePath -> IO (Table a) -csv_table_read' f = fmap snd . csv_table_read def_csv_opt f - --- | Read and process @CSV@ 'Table'. -csv_table_with :: CSV_Opt -> (String -> a) -> FilePath -> (CSV_Table a -> b) -> IO b -csv_table_with opt f fn g = fmap g (csv_table_read opt f fn) - --- > csv_table_align CSV_No_Align [["a","row","and"],["then","another","one"]] -csv_table_align :: CSV_Align_Columns -> Table String -> Table String -csv_table_align align tbl = - let c = transpose tbl - n = map (maximum . map length) c - ext k s = let pd = replicate (k - length s) ' ' - in case align of - CSV_No_Align -> s - CSV_Align_Left -> pd ++ s - CSV_Align_Right -> s ++ pd - in transpose (zipWith (map . ext) n c) - --- | Write 'Table' to @CSV@ file. -csv_table_write :: (a -> String) -> CSV_Opt -> FilePath -> CSV_Table a -> IO () -csv_table_write f (_,delim,brk,align) fn (hdr,tbl) = do - let tbl' = csv_table_align align (map (map f) tbl) - (_,t) = C.toCSVTable (T.mcons hdr tbl') - s = C.ppDSVTable brk delim t - writeFile fn s - --- | Write 'Table' only (no header). -csv_table_write' :: (a -> String) -> CSV_Opt -> FilePath -> Table a -> IO () -csv_table_write' f opt fn tbl = csv_table_write f opt fn (Nothing,tbl) - --- | @0@-indexed (row,column) cell lookup. -table_lookup :: Table a -> (Int,Int) -> a -table_lookup t (r,c) = (t !! r) !! c - --- | Row data. -table_row :: Table a -> Row_Ref -> [a] -table_row t r = t !! row_index r - --- | Column data. -table_column :: Table a -> Column_Ref -> [a] -table_column t c = transpose t !! column_index c - --- | Lookup value across columns. -table_column_lookup :: Eq a => Table a -> (Column_Ref,Column_Ref) -> a -> Maybe a -table_column_lookup t (c1,c2) e = - let a = zip (table_column t c1) (table_column t c2) - in lookup e a - --- | Table cell lookup. -table_cell :: Table a -> Cell_Ref -> a -table_cell t (c,r) = - let (r',c') = (row_index r,column_index c) - in table_lookup t (r',c') - --- | @0@-indexed (row,column) cell lookup over column range. -table_lookup_row_segment :: Table a -> (Int,(Int,Int)) -> [a] -table_lookup_row_segment t (r,(c0,c1)) = - let r' = t !! r - in take (c1 - c0 + 1) (drop c0 r') - --- | Range of cells from row. -table_row_segment :: Table a -> (Row_Ref,Column_Range) -> [a] -table_row_segment t (r,c) = - let (r',c') = (row_index r,column_indices c) - in table_lookup_row_segment t (r',c') - --- * Array - --- | Translate 'Table' to 'Array'. It is assumed that the 'Table' is --- regular, ie. all rows have an equal number of columns. --- --- > let a = table_to_array [[0,1,3],[2,4,5]] --- > in (bounds a,indices a,elems a) --- --- > > (((A,1),(C,2)) --- > > ,[(A,1),(A,2),(B,1),(B,2),(C,1),(C,2)] --- > > ,[0,2,1,4,3,5]) -table_to_array :: Table a -> Array Cell_Ref a -table_to_array t = - let nr = length t - nc = length (t !! 0) - bnd = (cell_ref_minima,(toEnum (nc - 1),nr)) - asc = zip (cell_range_row_order bnd) (concat t) - in array bnd asc - --- | 'table_to_array' of 'csv_table_read'. -csv_array_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (Array Cell_Ref a) -csv_array_read opt f fn = fmap (table_to_array . snd) (csv_table_read opt f fn) diff --git a/Music/Theory/Array/CSV/Midi.hs b/Music/Theory/Array/CSV/Midi.hs deleted file mode 100644 --- a/Music/Theory/Array/CSV/Midi.hs +++ /dev/null @@ -1,86 +0,0 @@ --- | Functions for reading midi note data from CSV files. -module Music.Theory.Array.CSV.Midi where - -import Data.Function {- base -} -import Data.Maybe {- base -} - -import qualified Music.Theory.Array.CSV as T {- hmt -} -import qualified Music.Theory.Time.Seq as T {- hmt -} - --- | Variant of 'reads' requiring exact match. -reads_exact :: Read a => String -> Maybe a -reads_exact s = - case reads s of - [(r,"")] -> Just r - _ -> Nothing - --- | Variant of 'reads_exact' that errors on failure. -reads_err :: Read a => String -> a -reads_err str = fromMaybe (error ("could not read: " ++ str)) (reads_exact str) - --- | The required header field. -csv_midi_note_data_hdr :: [String] -csv_midi_note_data_hdr = ["time","on/off","note","velocity"] - --- | Midi note data, header is @time,on/off,note,velocity@. --- Translation values for on/off are consulted. --- --- > let fn = "/home/rohan/cvs/uc/uc-26/daily-practice/2014-08-13.1.csv" --- > csv_midi_note_data_read' ("ON","OFF") fn :: IO [(Double,Either String String,Double,Double)] -csv_midi_note_data_read' :: (Read t,Real t,Read n,Real n) => (m,m) -> FilePath -> IO [(t,Either m String,n,n)] -csv_midi_note_data_read' (m_on,m_off) = - let err x = error ("csv_midi_note_data_read: " ++ x) - read_md x = case x of - "on" -> Left m_on - "off" -> Left m_off - _ -> Right x - f m = - case m of - [st,md,mnn,amp] -> (reads_err st,read_md md,reads_err mnn,reads_err amp) - _ -> err "entry?" - g (hdr,dat) = case hdr of - Just hdr' -> if hdr' == csv_midi_note_data_hdr then dat else err "header?" - Nothing -> err "no header?" - in fmap (map f . g) . T.csv_table_read (True,',',False,T.CSV_No_Align) id - --- | Variant of 'csv_midi_note_data_read'' that errors on non on/off data. -csv_midi_note_data_read :: (Read t,Real t,Read n,Real n) => (m,m) -> FilePath -> IO [(t,m,n,n)] -csv_midi_note_data_read m = - let f (t,p,q,r) = (t,either id (error "not on/off") p,q,r) - in fmap (map f) . csv_midi_note_data_read' m - --- | 'Tseq' form of 'csv_read_midi_note_data'. -midi_tseq_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.On_Off (n,n))) -midi_tseq_read = - let mk_node (st,md,mnn,amp) = if md - then (st,T.On (mnn,amp)) - else (st,T.Off (mnn,0)) - in fmap (map mk_node) . csv_midi_note_data_read (True,False) - --- | Translate from 'Tseq' form to 'Wseq' form. -midi_tseq_to_midi_wseq :: (Num t,Eq n) => T.Tseq t (T.On_Off (n,n)) -> T.Wseq t (n,n) -midi_tseq_to_midi_wseq = T.tseq_on_off_to_wseq ((==) `on` fst) - --- | Off-velocity is zero. -midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t (n,n) -> T.Tseq t (T.On_Off (n,n)) -midi_wseq_to_midi_tseq = T.wseq_on_off - --- | Writer. -csv_midi_note_data_write :: (Eq m,Show t,Real t,Show n,Real n) => (m,m) -> FilePath -> [(t,m,n,n)] -> IO () -csv_midi_note_data_write (m_on,m_off) nm = - let show_md md = if md == m_on - then "on" else if md == m_off - then "off" - else error "csv_midi_note_data_write" - un_node (st,md,mnn,amp) = [show st,show_md md,show mnn,show amp] - with_hdr dat = (Just csv_midi_note_data_hdr,dat) - in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node - --- | 'Tseq' form of 'csv_midi_note_data_write'. -midi_tseq_write :: (Show t,Real t,Show n,Real n) => FilePath -> T.Tseq t (T.On_Off (n,n)) -> IO () -midi_tseq_write nm sq = - let f (t,e) = case e of - T.On (n,v) -> (t,True,n,v) - T.Off (n,v) -> (t,False,n,v) - sq' = map f sq - in csv_midi_note_data_write (True,False) nm sq' diff --git a/Music/Theory/Array/Csv/Midi/Cli.hs b/Music/Theory/Array/Csv/Midi/Cli.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Csv/Midi/Cli.hs @@ -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" +-} + diff --git a/Music/Theory/Array/Csv/Midi/Mnd.hs b/Music/Theory/Array/Csv/Midi/Mnd.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Csv/Midi/Mnd.hs @@ -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 diff --git a/Music/Theory/Array/Csv/Midi/Skini.hs b/Music/Theory/Array/Csv/Midi/Skini.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Csv/Midi/Skini.hs @@ -0,0 +1,57 @@ +-- | Functions (partial) for reading & writing Skini data files. +-- +-- +module Music.Theory.Array.Csv.Midi.Skini where + +import Data.List {- base -} + +import qualified Music.Theory.Array.Csv.Midi.Mnd as T {- hmt -} +import qualified Music.Theory.Time.Seq as T {- hmt -} + +-- | Skini allows delta or absolute time-stamps. +data Time t = Delta t | Absolute t + +-- | Skini data type of (message,time-stamp,channel,data-one,data-two) +type Skini t n = (String,Time t,T.Channel,n,n) + +mnd_msg_to_skini_msg :: String -> String +mnd_msg_to_skini_msg msg = + case msg of + "on" -> "NoteOn" + "off" -> "NoteOff" + _ -> error "mnd_msg_to_skini_msg" + +mnd_to_skini_f :: (t -> Time t) -> T.Mnd t n -> Skini t n +mnd_to_skini_f f mnd = + case mnd of + (t,msg,d1,d2,ch,[]) -> (mnd_msg_to_skini_msg msg,f t,ch,d1,d2) + _ -> error "mnd_to_skini" + +mnd_to_skini_abs :: T.Mnd t n -> Skini t n +mnd_to_skini_abs = mnd_to_skini_f Absolute + +midi_tseq_to_skini_seq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (T.Event n)) -> [Skini t n] +midi_tseq_to_skini_seq = + let f e = + case e of + (t,T.Begin (d1,d2,ch,[])) -> ("NoteOn",Delta t,ch,d1,d2) + (t,T.End (d1,d2,ch,[])) -> ("NoteOff",Delta t,ch,d1,d2) + _ -> error "midi_tseq_to_skini_seq" + in map f . T.tseq_to_iseq + +time_pp :: Real t => Int -> Time t -> String +time_pp k t = + case t of + Delta x -> T.data_value_pp k x + Absolute x -> '=' : T.data_value_pp k x + +skini_pp_csv :: (Real t,Real n) => Int -> Skini t n -> String +skini_pp_csv k (msg,t,ch,d1,d2) = + let f = T.data_value_pp k + in intercalate "," [msg,time_pp k t,show ch,f d1,f d2] + +-- > let fn = "/home/rohan/sw/hmt/data/csv/mnd/1080-C01.csv" +-- > m <- T.csv_mnd_read_tseq fn :: IO (T.Tseq Double (T.Begin_End (T.Event Int))) +-- > skini_write_csv 4 "/tmp/t.skini" (midi_tseq_to_skini_seq m) +skini_write_csv :: (Real t,Real n) => Int -> FilePath -> [Skini t n] -> IO () +skini_write_csv k fn = writeFile fn . unlines . map (skini_pp_csv k) diff --git a/Music/Theory/Array/Direction.hs b/Music/Theory/Array/Direction.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Direction.hs @@ -0,0 +1,84 @@ +-- | Directions in an array. +module Music.Theory.Array.Direction where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Array.Cell_Ref as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} + +-- * LOC / VEC + +-- | (column,row) +type LOC n = (n,n) + +-- | (Δcolumn,Δrow), rows /descend/, ie. down is positive, up is negative. +type VEC n = (n,n) + +vector_add :: Num n => VEC n -> VEC n -> VEC n +vector_add (c1,r1) (c2,r2) = (c1 + c2,r1 + r2) + +vector_sub :: Num n => VEC n -> VEC n -> VEC n +vector_sub (c1,r1) (c2,r2) = (c1 - c2,r1 - r2) + +vector_sum :: Num n => [VEC n] -> VEC n +vector_sum = foldl1 vector_add + +apply_vec :: Num n => LOC n -> VEC n -> LOC n +apply_vec (c,r) (dc,dr) = (c + dc,r + dr) + +-- | Segment 'VEC' into a sequence of unit steps. +-- +-- > let r = [[(0,0)],[(0,1)],[(0,1),(-1,0)],[(0,1),(0,1),(0,1),(-1,0),(-1,0)]] +-- > in map segment_vec [(0,0),(0,1),(-1,1),(-2,3)] == r +segment_vec :: Integral n => VEC n -> [VEC n] +segment_vec v = + case v of + (0,0) -> [v] + (c,r) -> genericReplicate (abs r) (0,signum r) ++ genericReplicate (abs c) (signum c,0) + +derive_vec :: Num n => LOC n -> LOC n -> VEC n +derive_vec (c1,r1) (c2,r2) = (c2 - c1,r2 - r1) + +unfold_path :: Num n => LOC n -> [VEC n] -> [LOC n] +unfold_path = scanl apply_vec + +-- * DIRECTION (non-diagonal) + +type DIRECTION_S = String + +-- | Directions are D=down, L=left, R=right, U=up. +is_direction :: String -> Bool +is_direction = (`elem` "DLRU.") . head + +type DIRECTION_C = Char + +-- | Reads either S|D W|L E|R N|U, reverse lookup gives SWEN. A period +-- indicates (0,0). S=south, W=west, E=east, N=north. +direction_char_to_vector_tbl :: Num n => [(DIRECTION_C,VEC n)] +direction_char_to_vector_tbl = + [('.',(0,0)) + ,('S',(0,1)),('W',(-1,0)),('E',(1,0)),('N',(0,-1)) + ,('D',(0,1)),('L',(-1,0)),('R',(1,0)),('U',(0,-1))] + +-- > map direction_char_to_vector "LU" +direction_char_to_vector :: Num n => DIRECTION_C -> VEC n +direction_char_to_vector d = fromMaybe (error "dir?") $ lookup d direction_char_to_vector_tbl + +-- > let r = [(0,-1),(0,1),(-1,0),(1,0),(-1,-1),(1,1),(-2,0),(-1,-1)] +-- > in map direction_to_vector (words "U D L R UL DR LL LU") == r +direction_to_vector :: Num n => [DIRECTION_C] -> VEC n +direction_to_vector = vector_sum . map direction_char_to_vector + +vector_to_direction_char :: (Eq n, Num n) => VEC n -> DIRECTION_C +vector_to_direction_char v = + let r = T.reverse_lookup v direction_char_to_vector_tbl + in fromMaybe (error "vec->dir?") r + +-- | Direction sequence to cell references. +dir_seq_to_cell_seq :: (String,[String]) -> [String] +dir_seq_to_cell_seq (l,v) = + let p = map direction_to_vector v + c = T.parse_cell_index l + in map (T.cell_ref_pp . T.index_to_cell) (unfold_path c p) + diff --git a/Music/Theory/Array/MD.hs b/Music/Theory/Array/MD.hs deleted file mode 100644 --- a/Music/Theory/Array/MD.hs +++ /dev/null @@ -1,111 +0,0 @@ --- | Regular array data as markdown (MD) tables. -module Music.Theory.Array.MD where - -import Data.Char {- base -} -import Data.List {- base -} - -import qualified Music.Theory.List as T {- hmt -} - --- | Append /k/ to the right of /l/ until result has /n/ places. -pad_right :: a -> Int -> [a] -> [a] -pad_right k n l = take n (l ++ repeat k) - --- | Append /k/ to each row of /tbl/ as required to be regular (all --- rows equal length). -make_regular :: a -> [[a]] -> [[a]] -make_regular k tbl = - let z = maximum (map length tbl) - in map (pad_right k z) tbl - --- | Delete trailing 'Char' where 'isSpace' holds. -delete_trailing_whitespace :: [Char] -> [Char] -delete_trailing_whitespace = reverse . dropWhile isSpace . reverse - --- | Optional header row then data rows. -type MD_Table t = (Maybe [String],[[t]]) - --- | Join second table to right of initial table. -md_table_join :: MD_Table a -> MD_Table a -> MD_Table a -md_table_join (nm,c) (hdr,tbl) = - let hdr' = fmap (\h -> maybe h (++ h) nm) hdr - tbl' = map (\(i,r) -> i ++ r) (zip c tbl) - in (hdr',tbl') - --- | Add a row number column at the front of the table. -md_number_rows :: MD_Table String -> MD_Table String -md_number_rows (hdr,tbl) = - let hdr' = fmap ("#" :) hdr - tbl' = map (\(i,r) -> show i : r) (zip [1::Int ..] tbl) - in (hdr',tbl') - --- | Markdown table, perhaps with header. Table is in row order. --- Options are: /pad_left/. --- --- > md_table_opt False (Nothing,[["a","bc","def"],["ghij","klm","no","p"]]) -md_table_opt :: Bool -> MD_Table String -> [String] -md_table_opt pleft (hdr,t) = - let t' = maybe t (:t) hdr - c = transpose (make_regular "" t') - n = map (maximum . map length) c - ext k s = let pd = replicate (k - length s) ' ' - in if pleft then pd ++ s else s ++ pd - m = unwords (map (flip replicate '-') n) - w = map unwords (transpose (zipWith (map . ext) n c)) - d = map delete_trailing_whitespace w - in case hdr of - Nothing -> T.bracket (m,m) d - Just _ -> case d of - [] -> error "md_table" - d0:d' -> d0 : T.bracket (m,m) d' - -md_table' :: MD_Table String -> [String] -md_table' = md_table_opt True - --- | 'curry' of 'md_table''. -md_table :: Maybe [String] -> [[String]] -> [String] -md_table = curry md_table' - --- | Variant relying on 'Show' instances. --- --- > md_table_show Nothing [[1..4],[5..8],[9..12]] -md_table_show :: Show t => Maybe [String] -> [[t]] -> [String] -md_table_show hdr = md_table hdr . map (map show) - --- | Variant in column order (ie. 'transpose'). --- --- > md_table_column_order [["a","bc","def"],["ghij","klm","no"]] -md_table_column_order :: Maybe [String] -> [[String]] -> [String] -md_table_column_order hdr = md_table hdr . transpose - --- | Two-tuple 'show' variant. -md_table_p2 :: (Show a,Show b) => Maybe [String] -> ([a],[b]) -> [String] -md_table_p2 hdr (p,q) = md_table hdr [map show p,map show q] - --- | Three-tuple 'show' variant. -md_table_p3 :: (Show a,Show b,Show c) => Maybe [String] -> ([a],[b],[c]) -> [String] -md_table_p3 hdr (p,q,r) = md_table hdr [map show p,map show q,map show r] - -{- | Matrix form, ie. header in both first row and first column, in -each case displaced by one location which is empty. - -> let t = md_matrix "" (map return "abc") (map (map show) [[1,2,3],[2,3,1],[3,1,2]]) - ->>> putStrLn $ unlines $ md_table' t -- - - - - a b c -a 1 2 3 -b 2 3 1 -c 3 1 2 -- - - - - --} -md_matrix :: a -> [a] -> [[a]] -> MD_Table a -md_matrix nil nm t = md_table_join (Nothing,[nil] : map return nm) (Nothing,nm : t) - --- | Variant for 'String' tables where /nil/ is the empty string and --- the header cells are in bold. -md_matrix_bold :: [String] -> [[String]] -> MD_Table String -md_matrix_bold nm t = - let bold x = "__" ++ x ++ "__" - nm' = map bold nm - in md_matrix "" nm' t diff --git a/Music/Theory/Array/Square.hs b/Music/Theory/Array/Square.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Array/Square.hs @@ -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 + diff --git a/Music/Theory/Bjorklund.hs b/Music/Theory/Bjorklund.hs --- a/Music/Theory/Bjorklund.hs +++ b/Music/Theory/Bjorklund.hs @@ -3,111 +3,138 @@ -- /Journal of Computational Geometry: Theory and Applications/ -- Volume 42, Issue 5, July, 2009 -- () -module Music.Theory.Bjorklund (bjorklund,xdot,iseq,iseq_str) where +module Music.Theory.Bjorklund where import Data.List.Split {- split -} -type STEP a = ((Int,Int),([[a]],[[a]])) +import qualified Music.Theory.List as T -left :: STEP a -> STEP a -left ((i,j),(xs,ys)) = +-- | Bjorklund state +type BJORKLUND_ST a = ((Int,Int),([[a]],[[a]])) + +-- | 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] --- > xdot (bjorklund (5,9)) == "x.x.x.x.x" --- --- > let es = [(2,3),(2,5) --- > ,(3,4),(3,5),(3,8) --- > ,(4,7),(4,9),(4,12),(4,15) --- > ,(5,6),(5,7),(5,8),(5,9),(5,11),(5,12),(5,13),(5,16) --- > ,(6,7),(6,13) --- > ,(7,8),(7,9),(7,10),(7,12),(7,15),(7,16),(7,17),(7,18) --- > ,(8,17),(8,19) --- > ,(9,14),(9,16),(9,22),(9,23) --- > ,(11,12),(11,24) --- > ,(13,24) --- > ,(15,34)] --- > in map (\e -> let e' = bjorklund e in (e,xdot e',iseq_str e')) es --- --- > [((2,3),"xx.","(12)") --- > ,((2,5),"x.x..","(23)") --- > ,((3,4),"xxx.","(112)") --- > ,((3,5),"x.x.x","(221)") --- > ,((3,8),"x..x..x.","(332)") --- > ,((4,7),"x.x.x.x","(2221)") --- > ,((4,9),"x.x.x.x..","(2223)") --- > ,((4,12),"x..x..x..x..","(3333)") --- > ,((4,15),"x...x...x...x..","(4443)") --- > ,((5,6),"xxxxx.","(11112)") --- > ,((5,7),"x.xx.xx","(21211)") --- > ,((5,8),"x.xx.xx.","(21212)") --- > ,((5,9),"x.x.x.x.x","(22221)") --- > ,((5,11),"x.x.x.x.x..","(22223)") --- > ,((5,12),"x..x.x..x.x.","(32322)") --- > ,((5,13),"x..x.x..x.x..","(32323)") --- > ,((5,16),"x..x..x..x..x...","(33334)") --- > ,((6,7),"xxxxxx.","(111112)") --- > ,((6,13),"x.x.x.x.x.x..","(222223)") --- > ,((7,8),"xxxxxxx.","(1111112)") --- > ,((7,9),"x.xxx.xxx","(2112111)") --- > ,((7,10),"x.xx.xx.xx","(2121211)") --- > ,((7,12),"x.xx.x.xx.x.","(2122122)") --- > ,((7,15),"x.x.x.x.x.x.x..","(2222223)") --- > ,((7,16),"x..x.x.x..x.x.x.","(3223222)") --- > ,((7,17),"x..x.x..x.x..x.x.","(3232322)") --- > ,((7,18),"x..x.x..x.x..x.x..","(3232323)") --- > ,((8,17),"x.x.x.x.x.x.x.x..","(22222223)") --- > ,((8,19),"x..x.x.x..x.x.x..x.","(32232232)") --- > ,((9,14),"x.xx.xx.xx.xx.","(212121212)") --- > ,((9,16),"x.xx.x.x.xx.x.x.","(212221222)") --- > ,((9,22),"x..x.x..x.x..x.x..x.x.","(323232322)") --- > ,((9,23),"x..x.x..x.x..x.x..x.x..","(323232323)") --- > ,((11,12),"xxxxxxxxxxx.","(11111111112)") --- > ,((11,24),"x..x.x.x.x.x..x.x.x.x.x.","(32222322222)") --- > ,((13,24),"x.xx.x.x.x.x.xx.x.x.x.x.","(2122222122222)") --- > ,((15,34),"x..x.x.x.x..x.x.x.x..x.x.x.x..x.x.","(322232223222322)")] +{- | 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_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])] +> let es' = concatMap (\(i,j) -> map ((,) i) j) es +> mapM_ (putStrLn . euler_pp_unicode) es' + +> > E(2,3) [××·] (12) +> > E(2,5) [×·×··] (23) +> > E(3,4) [×××·] (112) +> > E(3,5) [×·×·×] (221) +> > E(3,8) [×··×··×·] (332) +> > E(4,7) [×·×·×·×] (2221) +> > E(4,9) [×·×·×·×··] (2223) +> > E(4,12) [×··×··×··×··] (3333) +> > E(4,15) [×···×···×···×··] (4443) +> > E(5,6) [×××××·] (11112) +> > E(5,7) [×·××·××] (21211) +> > E(5,8) [×·××·××·] (21212) +> > E(5,9) [×·×·×·×·×] (22221) +> > E(5,11) [×·×·×·×·×··] (22223) +> > E(5,12) [×··×·×··×·×·] (32322) +> > E(5,13) [×··×·×··×·×··] (32323) +> > E(5,16) [×··×··×··×··×···] (33334) +> > E(6,7) [××××××·] (111112) +> > E(6,13) [×·×·×·×·×·×··] (222223) +> > E(7,8) [×××××××·] (1111112) +> > E(7,9) [×·×××·×××] (2112111) +> > E(7,10) [×·××·××·××] (2121211) +> > E(7,12) [×·××·×·××·×·] (2122122) +> > E(7,15) [×·×·×·×·×·×·×··] (2222223) +> > E(7,16) [×··×·×·×··×·×·×·] (3223222) +> > E(7,17) [×··×·×··×·×··×·×·] (3232322) +> > E(7,18) [×··×·×··×·×··×·×··] (3232323) +> > E(8,17) [×·×·×·×·×·×·×·×··] (22222223) +> > E(8,19) [×··×·×·×··×·×·×··×·] (32232232) +> > E(9,14) [×·××·××·××·××·] (212121212) +> > E(9,16) [×·××·×·×·××·×·×·] (212221222) +> > E(9,22) [×··×·×··×·×··×·×··×·×·] (323232322) +> > E(9,23) [×··×·×··×·×··×·×··×·×··] (323232323) +> > E(11,12) [×××××××××××·] (11111111112) +> > E(11,24) [×··×·×·×·×·×··×·×·×·×·×·] (32222322222) +> > E(13,24) [×·××·×·×·×·×·××·×·×·×·×·] (2122222122222) +> > E(15,34) [×··×·×·×·×··×·×·×·×··×·×·×·×··×·×·] (322232223222322) + +-} bjorklund :: (Int,Int) -> [Bool] bjorklund (i,j') = 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_unicode (bjorklund_r 2 (5,16)) == "··×··×··×··×··×·" +bjorklund_r :: Int -> (Int, Int) -> [Bool] +bjorklund_r n = T.rotate_right n . bjorklund + +-- | Pretty printer, generalise. +euler_pp_f :: (Bool -> Char) -> (Int,Int) -> String +euler_pp_f f e = + let r = bjorklund e + in concat ["E",show e," [",map f r,"] ",iseq_str r] + +-- | Unicode form, ie. @×·@. +-- +-- > 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_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. -- --- > xdot (bjorklund (5,9)) == "x.x.x.x.x" -xdot :: [Bool] -> String -xdot = map (\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_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 diff --git a/Music/Theory/Block_Design/Johnson_2007.hs b/Music/Theory/Block_Design/Johnson_2007.hs --- a/Music/Theory/Block_Design/Johnson_2007.hs +++ b/Music/Theory/Block_Design/Johnson_2007.hs @@ -2,7 +2,7 @@ -- Computation in Music, Berlin, May 2007. module Music.Theory.Block_Design.Johnson_2007 where -import Control.Arrow {- base -} +import Control.Arrow ((***)) {- base -} import Data.List {- base -} import qualified Music.Theory.List as T diff --git a/Music/Theory/Braille.hs b/Music/Theory/Braille.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Braille.hs @@ -0,0 +1,274 @@ +-- | +module Music.Theory.Braille where + +import Data.Char {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Text.Printf {- base -} + +-- | Braille coding data. Elements are: (ASCII HEX,ASCII CHAR,DOT +-- LIST,UNICODE CHAR,MEANING). The dot numbers are in column order. +type BRAILLE = (Int,Char,[Int],Char,String) + +-- | ASCII 'Char' of 'BRAILLE'. +braille_ascii :: BRAILLE -> Char +braille_ascii (_,c,_,_,_) = c + +-- | Unicode 'Char' of 'BRAILLE'. +braille_unicode :: BRAILLE -> Char +braille_unicode (_,_,_,c,_) = c + +-- | Dot list of 'BRAILLE'. +braille_dots :: BRAILLE -> [Int] +braille_dots (_,_,d,_,_) = d + +-- | ASCII Braille table. +-- +-- > all id (map (\(x,c,_,_,_) -> x == fromEnum c) braille_table) == True +braille_table :: [BRAILLE] +braille_table = + [(0x20,' ',[],'⠀'," ") + ,(0x21,'!',[2,3,4,6],'⠮',"the") + ,(0x22,'"',[5],'⠐',"contraction") + ,(0x23,'#',[3,4,5,6],'⠼',"number prefix") + ,(0x24,'$',[1,2,4,6],'⠫',"ed") + ,(0x25,'%',[1,4,6],'⠩',"sh") + ,(0x26,'&',[1,2,3,4,6],'⠯',"and") + ,(0x27,'\'',[3],'⠄',"'") + ,(0x28,'(',[1,2,3,5,6],'⠷',"of") + ,(0x29,')',[2,3,4,5,6],'⠾',"with") + ,(0x2A,'*',[1,6],'⠡',"ch") + ,(0x2B,'+',[3,4,6],'⠬',"ing") + ,(0x2C,',',[6],'⠠',"uppercase prefix") + ,(0x2D,'-',[3,6],'⠤',"-") + ,(0x2E,'.',[4,6],'⠨',"italic prefix") + ,(0x2F,'/',[3,4],'⠌',"st") + ,(0x30,'0',[3,5,6],'⠴',"”") + ,(0x31,'1',[2],'⠂',",") + ,(0x32,'2',[2,3],'⠆',";") + ,(0x33,'3',[2,5],'⠒',":") + ,(0x34,'4',[2,5,6],'⠲',".") + ,(0x35,'5',[2,6],'⠢',"en") + ,(0x36,'6',[2,3,5],'⠖',"!") + ,(0x37,'7',[2,3,5,6],'⠶',"( or )") + ,(0x38,'8',[2,3,6],'⠦',"“ or ?") + ,(0x39,'9',[3,5],'⠔',"in") + ,(0x3A,':',[1,5,6],'⠱',"wh") + ,(0x3B,';',[5,6],'⠰',"letter prefix") + ,(0x3C,'<',[1,2,6],'⠣',"gh") + ,(0x3D,'=',[1,2,3,4,5,6],'⠿',"for") + ,(0x3E,'>',[3,4,5],'⠜',"ar") + ,(0x3F,'?',[1,4,5,6],'⠹',"th") + ,(0x40,'@',[4],'⠈',"accent prefix") + ,(0x41,'A',[1],'⠁',"a") + ,(0x42,'B',[1,2],'⠃',"b") + ,(0x43,'C',[1,4],'⠉',"c") + ,(0x44,'D',[1,4,5],'⠙',"d") + ,(0x45,'E',[1,5],'⠑',"e") + ,(0x46,'F',[1,2,4],'⠋',"f") + ,(0x47,'G',[1,2,4,5],'⠛',"g") + ,(0x48,'H',[1,2,5],'⠓',"h") + ,(0x49,'I',[2,4],'⠊',"i") + ,(0x4A,'J',[2,4,5],'⠚',"j") + ,(0x4B,'K',[1,3],'⠅',"k") + ,(0x4C,'L',[1,2,3],'⠇',"l") + ,(0x4D,'M',[1,3,4],'⠍',"m") + ,(0x4E,'N',[1,3,4,5],'⠝',"n") + ,(0x4F,'O',[1,3,5],'⠕',"o") + ,(0x50,'P',[1,2,3,4],'⠏',"p") + ,(0x51,'Q',[1,2,3,4,5],'⠟',"q") + ,(0x52,'R',[1,2,3,5],'⠗',"r") + ,(0x53,'S',[2,3,4],'⠎',"s") + ,(0x54,'T',[2,3,4,5],'⠞',"t") + ,(0x55,'U',[1,3,6],'⠥',"u") + ,(0x56,'V',[1,2,3,6],'⠧',"v") + ,(0x57,'W',[2,4,5,6],'⠺',"w") + ,(0x58,'X',[1,3,4,6],'⠭',"x") + ,(0x59,'Y',[1,3,4,5,6],'⠽',"y") + ,(0x5A,'Z',[1,3,5,6],'⠵',"z") + ,(0x5B,'[',[2,4,6],'⠪',"ow") + ,(0x5C,'\\',[1,2,5,6],'⠳',"ou") + ,(0x5D,']',[1,2,4,5,6],'⠻',"er") + ,(0x5E,'^',[4,5],'⠘',"currency prefix") + ,(0x5F,'_',[4,5,6],'⠸',"contraction") + ] + +-- | Lookup 'BRAILLE' value for unicode character. +-- +-- > braille_lookup_unicode '⠝' == Just (0x4E,'N',[1,3,4,5],'⠝',"n") +braille_lookup_unicode :: Char -> Maybe BRAILLE +braille_lookup_unicode c = find ((== c) . braille_unicode) braille_table + +-- | Lookup 'BRAILLE' value for ascii character (case invariant). +-- +-- > 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 + +-- | 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 +-- cell, the two cells to the right are the first two cells of the +-- decade shifted right. +-- +-- For each decade there are two extra cells that shift +-- the first two cells of the decade right one place. Subsequent +-- decades are derived by simple transformation of the first. The +-- second is the first with the addition of dot @3@, the third adds +-- dots @3@ and @6@, the fourth adds dot @6@ and the fifth shifts the +-- first down one row. +-- +-- The first decade has the 13 of the 16 4-dot patterns, the remaining +-- 3 are in the fifth decade, that is they are the three 4-dot +-- patterns that are down shifts of a 4-dot pattern. +-- +-- > let trimap f (p,q,r) = (f p,f q,f r) +-- > let f = map (fromJust . decode) in map (trimap f) braille_64 +braille_64 :: [(String,String,String)] +braille_64 = + [("⠀","⠁⠃⠉⠙⠑⠋⠛⠓⠊⠚","⠈⠘") + ,("⠄","⠅⠇⠍⠝⠕⠏⠟⠗⠎⠞","⠌⠜") + ,("⠤","⠥⠧⠭⠽⠵⠯⠿⠷⠮⠾","⠬⠼") + ,("⠠","⠡⠣⠩⠹⠱⠫⠻⠳⠪⠺","⠨⠸") + ,("","⠂⠆⠒⠲⠢⠖⠶⠦⠔⠴","⠐⠰")] + +-- | Transcribe ASCII to unicode braille. +-- +-- > transcribe_unicode "BRAILLE ASCII CHAR GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠁⠎⠉⠊⠊⠀⠉⠓⠁⠗⠀⠛⠗⠊⠙" +-- > transcribe_unicode "BRAILLE HTML TABLE GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠓⠞⠍⠇⠀⠞⠁⠃⠇⠑⠀⠛⠗⠊⠙" +transcribe_unicode :: String -> String +transcribe_unicode = map (braille_unicode . fromJust . braille_lookup_ascii) + +-- | Generate a character grid using inidicated values for filled and empty cells. +-- +-- > let ch = (' ','.') +-- > putStrLn$ transcribe_char_grid ch "BRAILLE ASCII CHAR GRID" +-- +-- > let ch = (white_circle,black_circle) +-- > putStrLn$ string_html_table $ transcribe_char_grid ch "BRAILLE HTML TABLE GRID" +transcribe_char_grid :: (Char,Char) -> String -> String +transcribe_char_grid (w,b) = + unlines . + map concat . + transpose . + map (dots_grid (w,b) . braille_dots . fromJust . braille_lookup_ascii) + +-- | Generate 6-dot grid given (white,black) values. +-- +-- > dots_grid (0,1) [1,2,3,5] == [[1,0],[1,1],[1,0]] +dots_grid :: (c,c) -> [Int] -> [[c]] +dots_grid (w,b) d = + 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 = "" ++ [x] ++ "" + g x = "" ++ concatMap f x ++ "" + h x = "" ++ concatMap g x ++ "
" + in h (lines s) + +{- | Decoding. + +> let t0 = ["⠠⠁⠇⠇⠀⠓⠥⠍⠁⠝⠀⠆⠬⠎⠀⠜⠑⠀⠃⠕⠗⠝⠀⠋⠗⠑⠑⠀⠯⠀⠑⠟⠥⠁⠇⠀⠔⠀⠙⠊⠛⠝⠰⠽⠀⠯⠀⠐⠗⠎⠲" +> ,"⠠⠮⠽⠀⠜⠑⠀⠢⠙⠪⠫⠀⠾⠀⠗⠂⠎⠕⠝⠀⠯⠀⠒⠎⠉⠊⠰⠑⠀⠯⠀⠩⠙⠀⠁⠉⠞⠀⠞⠪⠜⠙⠎⠀⠐⠕⠀⠁⠝⠕⠤" +> ,"⠮⠗⠀⠔⠀⠁⠀⠸⠎⠀⠷⠀⠃⠗⠕⠮⠗⠓⠕⠕⠙⠲"] + +> concatMap (fromMaybe "#" . decode) (concat t0) + +-} +decode :: Char -> Maybe String +decode c = + case braille_lookup_unicode c of + Just (_,_,_,_,s) -> Just s + Nothing -> Nothing + +-- | Start and end unicode indices. +braille_rng :: Integral i => (i,i) +braille_rng = (0x2800,0x28FF) + +-- | All characters, in sequence. +-- +-- > length braille_seq == 256 +-- > putStrLn braille_seq +braille_seq :: [Char] +braille_seq = let (l,r) = braille_rng in [toEnum l .. toEnum r] + +-- | The /n/th character, zero indexed. +braille_char :: Int -> Char +braille_char = toEnum . (+) 0x2800 + +-- | Two element index, 255 * 255 = 65025 places. +-- +-- > map braille_ix [100,300] +braille_ix :: Int -> (Char,Char) +braille_ix n = + let (i,j) = n `divMod` 255 + f k = braille_char (k + 1) + in (f i,f j) + +-- | HTML character encoding (as hex integer). +-- +-- > unwords $ map unicode_html braille_seq +unicode_html :: Char -> String +unicode_html = printf "&#x%x;" . fromEnum + +-- * Unicode + +-- | White (empty) circle. +white_circle :: Char +white_circle = '○' + +-- | Black (filled) circle. +black_circle :: Char +black_circle = '●' + +-- | Shaded (hatched) circle. +shaded_circle :: Char +shaded_circle = '◍' + +-- * Contractions + +-- | Table of one letter contractions. +one_letter_contractions :: [(Char,String)] +one_letter_contractions = + [('⠃',"but") + ,('⠉',"can") + ,('⠙',"do") + ,('⠑',"every") + ,('⠋',"from,-self") + ,('⠛',"go") + ,('⠓',"have") + ,('⠚',"just") + ,('⠅',"knowledge") + ,('⠇',"like") + ,('⠍',"more") + ,('⠝',"not") + ,('⠏',"people") + ,('⠟',"quite") + ,('⠗',"rather") + ,('⠎',"so") + ,('⠞',"that") + ,('⠌',"still") + ,('⠥',"us") + ,('⠧',"very") + ,('⠭',"it") + ,('⠽',"you") + ,('⠵',"as") + ,('⠡',"child") + ,('⠩',"shall") + ,('⠹',"this") + ,('⠱',"which") + ,('⠳',"out") + ,('⠺',"will") + ,('⠆',"be,be-") + ,('⠒',"con-") + ,('⠲',"dis-") + ,('⠢',"enough") + ,('⠖',"to") + ,('⠶',"were") + ,('⠦',"his") + ,('⠔',"in") + ,('⠴',"by,was") + ,('⠤',"com-") + ] diff --git a/Music/Theory/Clef.hs b/Music/Theory/Clef.hs --- a/Music/Theory/Clef.hs +++ b/Music/Theory/Clef.hs @@ -1,15 +1,15 @@ -- | Common music notation clefs. module Music.Theory.Clef where -import Music.Theory.Pitch -import Music.Theory.Pitch.Name +import Music.Theory.Pitch {- hmt -} +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) diff --git a/Music/Theory/Combinations.hs b/Music/Theory/Combinations.hs deleted file mode 100644 --- a/Music/Theory/Combinations.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Combination functions. -module Music.Theory.Combinations where - -import Music.Theory.Permutations - --- | Number of /k/ element combinations of a set of /n/ elements. --- --- > (nk_combinations 6 3,nk_combinations 13 3) == (20,286) -nk_combinations :: Integral a => a -> a -> a -nk_combinations n k = nk_permutations n k `div` 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 :: Integral t => t -> [a] -> [[a]] -combinations k s = - case (k,s) of - (0,_) -> [[]] - (_,[]) -> [] - (_,e:s') -> map (e :) (combinations (k - 1) s') ++ combinations k s' diff --git a/Music/Theory/Contour/Polansky_1992.hs b/Music/Theory/Contour/Polansky_1992.hs --- a/Music/Theory/Contour/Polansky_1992.hs +++ b/Music/Theory/Contour/Polansky_1992.hs @@ -10,33 +10,14 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import qualified Music.Theory.Set.List as T -import qualified Music.Theory.Permutations.List as T - --- * List functions - --- | Replace the /i/th value at /ns/ with /x/. --- --- > replace "test" 2 'n' == "tent" -replace :: Integral i => [a] -> i -> a -> [a] -replace ns i x = - let f j y = if i == j then x else y - in zipWith f [0..] ns +import qualified Music.Theory.List as T {- hmt-base -} +import qualified Music.Theory.Ord as T {- hmt-base -} --- | Are all elements equal. --- --- > all_equal "aaa" == True -all_equal :: Eq a => [a] -> Bool -all_equal xs = all id (zipWith (==) xs (tail xs)) +import qualified Music.Theory.Permutations.List as T {- hmt -} +import qualified Music.Theory.Set.List as T {- hmt -} -- * Indices --- | Compare adjacent elements (p.262) left to right. --- --- > compare_adjacent [0,1,3,2] == [LT,LT,GT] -compare_adjacent :: Ord a => [a] -> [Ordering] -compare_adjacent xs = zipWith compare xs (tail xs) - -- | Construct set of /n/ '-' @1@ adjacent indices, left right order. -- -- > adjacent_indices 5 == [(0,1),(1,2),(2,3),(3,4)] @@ -51,36 +32,6 @@ let n' = n - 1 in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']] --- * 'Enum' functions - --- | 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 - --- * 'Ordering' functions - --- | Specialised 'genericFromEnum'. -ord_to_int :: Integral a => Ordering -> a -ord_to_int = genericFromEnum - --- | Specialised 'genericToEnum'. -int_to_ord :: Integral a => a -> Ordering -int_to_ord = genericToEnum - --- | 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 - -- * Matrix -- | A list notation for matrices. @@ -109,7 +60,7 @@ data Contour_Half_Matrix = Contour_Half_Matrix {contour_half_matrix_n :: Int ,contour_half_matrix_m :: Matrix Ordering} - deriving (Eq) + deriving (Eq,Ord) -- | Half 'Matrix' of contour given comparison function /f/. -- @@ -183,7 +134,7 @@ -- > let c = ["abc","bbb","cba"] -- > in map (uniform.contour_description) c == [True,True,True] uniform :: Contour_Description -> Bool -uniform (Contour_Description _ m) = all_equal (M.elems m) +uniform (Contour_Description _ m) = T.all_equal (M.elems m) -- | 'True' if contour does not containt any 'EQ' elements. -- @@ -317,7 +268,7 @@ LT -> i' + adjustment j' EQ -> i' GT -> i' - adjustment j' - in Just (replace ns j j'') + in Just (T.replace_at ns j j'') refine [] ns = ns refine (i:is) ns = case step i ns of Nothing -> refine is ns @@ -330,7 +281,7 @@ -- > in draw_contour (contour_description_invert c) == [3,2,0,1] contour_description_invert :: Contour_Description -> Contour_Description contour_description_invert (Contour_Description n m) = - Contour_Description n (M.map ord_invert m) + Contour_Description n (M.map T.ord_invert m) -- * Construction @@ -499,5 +450,5 @@ ex_4 = let ns :: [[Int]] ns = [[2,2,2,1],[2,2,0],[0,0],[1]] - ns' = map (map int_to_ord) ns + ns' = map (map T.int_to_ord) ns in half_matrix_to_description (Contour_Half_Matrix 5 ns') diff --git a/Music/Theory/Db/Cli.hs b/Music/Theory/Db/Cli.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Db/Cli.hs @@ -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) diff --git a/Music/Theory/Db/Common.hs b/Music/Theory/Db/Common.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Db/Common.hs @@ -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) diff --git a/Music/Theory/Db/Csv.hs b/Music/Theory/Db/Csv.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Db/Csv.hs @@ -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 diff --git a/Music/Theory/Db/Plain.hs b/Music/Theory/Db/Plain.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Db/Plain.hs @@ -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)) diff --git a/Music/Theory/Duration.hs b/Music/Theory/Duration.hs --- a/Music/Theory/Duration.hs +++ b/Music/Theory/Duration.hs @@ -1,22 +1,32 @@ -- | 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 -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Ord as T {- hmt -} + +type Division = Integer +type Dots = Int + -- | Common music notation durational model -data Duration = Duration {division :: Integer -- ^ division of whole note - ,dots :: Integer -- ^ number of dots - ,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 duration_meq p q = multiplier p == multiplier q +-- | Is multiplier the identity (ie. @1@)? +duration_m1 :: Duration -> Bool +duration_m1 = (== 1) . multiplier + -- | Compare durations with equal multipliers. duration_compare_meq :: Duration -> Duration -> Maybe Ordering duration_compare_meq y0 y1 = @@ -40,158 +50,167 @@ instance Ord Duration where compare = duration_compare_meq_err -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) - -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) - -- | True if neither duration is dotted. no_dots :: (Duration, Duration) -> Bool no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0 -- | Sum undotted divisions, input is required to be sorted. -sum_dur_undotted :: (Integer, Integer) -> Maybe Duration -sum_dur_undotted (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 :: (Integer,Integer,Integer,Integer) -> 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 (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' :: Duration -> Duration -> Duration -sum_dur' y0 y1 = +sum_dur_err :: Duration -> Duration -> Duration +sum_dur_err y0 y1 = let y2 = sum_dur y0 y1 err = error ("sum_dur': " ++ show (y0,y1)) in fromMaybe err y2 --- | Give @MusicXML@ type for division. +{- | 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] + +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_std_set, dt <- [0..k]] + +-- | Table of number of beams at notated division. +beam_count_tbl :: [(Division,Int)] +beam_count_tbl = zip divisions_musicxml_set [0,0,0,0,0,1,2,3,4,5,6] + +-- | Lookup 'beam_count_tbl'. -- +-- > whole_note_division_to_beam_count 32 == Just 3 +whole_note_division_to_beam_count :: Division -> Maybe Int +whole_note_division_to_beam_count x = lookup x beam_count_tbl + +-- | Calculate number of beams at 'Duration'. +-- +-- > map duration_beam_count [Duration 2 0 1,Duration 16 0 1] == [0,2] +duration_beam_count :: Duration -> Int +duration_beam_count (Duration x _ _) = + let err = error "duration_beam_count" + bc = whole_note_division_to_beam_count x + in fromMaybe err bc + +-- * MusicXml + +-- | 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 divisions_musicxml_set nm + +-- | Lookup 'division_musicxml_tbl'. +-- -- > map whole_note_division_to_musicxml_type [2,4] == ["half","quarter"] -whole_note_division_to_musicxml_type :: Integer -> String +whole_note_division_to_musicxml_type :: Division -> String whole_note_division_to_musicxml_type x = - case x of - 256 -> "256th" - 128 -> "128th" - 64 -> "64th" - 32 -> "32nd" - 16 -> "16th" - 8 -> "eighth" - 4 -> "quarter" - 2 -> "half" - 1 -> "whole" - 0 -> "breve" - -1 -> "long" - _ -> error ("whole_note_division_to_musicxml_type: " ++ show x) + T.lookup_err_msg "division_musicxml_tbl" x division_musicxml_tbl -- | Variant of 'whole_note_division_to_musicxml_type' extracting --- 'division' from 'Duration'. +-- 'division' from 'Duration', dots & multipler are ignored. -- --- > duration_to_musicxml_type quarter_note == "quarter" +-- > duration_to_musicxml_type (Duration 4 0 1) == "quarter" duration_to_musicxml_type :: Duration -> String duration_to_musicxml_type = whole_note_division_to_musicxml_type . division --- | Give /Lilypond/ notation for 'Duration'. Note that the duration --- multiplier is /not/ written. +-- * Unicode + +-- | Table giving @Unicode@ symbols for divisions. +division_unicode_tbl :: [(Integer,Char)] +division_unicode_tbl = zip [0,1,2,4,8,16,32,64,128,256] "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲" + +-- | Lookup 'division_unicode_tbl'. -- --- > import Music.Theory.Duration.Name --- > map duration_to_lilypond_type [half_note,dotted_quarter_note] == ["2","4."] +-- > map whole_note_division_to_unicode_symbol [1,2,4,8] == "𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮" +whole_note_division_to_unicode_symbol :: Division -> Char +whole_note_division_to_unicode_symbol x = + T.lookup_err_msg "division_unicode_tbl" x division_unicode_tbl + +-- | Give Unicode string for 'Duration'. The duration multiplier is /not/ written. +-- +-- > map duration_to_unicode [Duration 1 2 1,Duration 4 1 1] == ["𝅝𝅭𝅭","𝅘𝅥𝅭"] +duration_to_unicode :: Duration -> String +duration_to_unicode (Duration dv d _) = + let dv' = whole_note_division_to_unicode_symbol dv + in dv' : replicate (fromIntegral d) '𝅭' + +-- * Lilypond + +-- | Give /Lilypond/ notation for 'Duration'. +-- Note that the duration multiplier is /not/ written. +-- +-- > map duration_to_lilypond_type [Duration 2 0 1,Duration 4 1 1] == ["2","4."] duration_to_lilypond_type :: Duration -> String duration_to_lilypond_type (Duration dv d _) = let dv' = if dv == 0 then "\\breve" else show dv in dv' ++ replicate (fromIntegral d) '.' --- | Calculate number of beams at notated division. --- --- > whole_note_division_to_beam_count 32 == Just 3 -whole_note_division_to_beam_count :: Integer -> Maybe Integer -whole_note_division_to_beam_count x = - let t = [(256,6),(128,5),(64,4),(32,3),(16,2),(8,1) - ,(4,0),(2,0),(1,0),(0,0),(-1,0)] - in lookup x t +-- * Humdrum --- | Calculate number of beams at 'Duration'. --- --- > map duration_beam_count [half_note,sixteenth_note] == [0,2] -duration_beam_count :: Duration -> Integer -duration_beam_count (Duration x _ _) = - let err = error "duration_beam_count" - bc = whole_note_division_to_beam_count x - in fromMaybe err bc +{- | Duration to @**recip@ notation. -whole_note_division_pp :: Integer -> Maybe Char -whole_note_division_pp x = - let t = [(16,'s'),(8,'e'),(4,'q'),(2,'h'),(1,'w')] - in lookup x t + --- > import Music.Theory.Duration.Name.Abbreviation --- > map duration_pp [q,h',e''] == [Just "q",Just "h'",Just "e''"] -duration_pp :: Duration -> Maybe String -duration_pp (Duration x d m) = - let d' = genericReplicate d '\'' - m' = case (numerator m,denominator m) of - (1,1) -> "" - (1,i) -> '/' : show i - (i,j) -> '*' : show i ++ "/" ++ show j - in case whole_note_division_pp x of - Just x' -> Just (x' : d' ++ m') - _ -> Nothing +> let d = map (\z -> Duration z 0 1) [0,1,2,4,8,16,32] +> map duration_recip_pp d == ["0","1","2","4","8","16","32"] --- | Duration to @**recip@ notation. --- --- http://humdrum.org/Humdrum/representations/recip.rep.html --- --- > let d = map (\z -> Duration z 0 1) [0,1,2,4,8,16,32] --- > in map duration_recip_pp d == ["0","1","2","4","8","16","32"] --- --- > let d = [Duration 1 1 (1/3),Duration 4 1 1,Duration 4 1 (2/3)] --- > in map duration_recip_pp d == ["3.","4.","6."] +> let d = [Duration 1 1 (1/3),Duration 4 1 1,Duration 4 1 (2/3)] +> map duration_recip_pp d == ["3.","4.","6."] +-} duration_recip_pp :: Duration -> String duration_recip_pp (Duration x d m) = let (mn,md) = (numerator m,denominator m) @@ -199,3 +218,43 @@ in if denominator r == 1 then show (numerator r) ++ genericReplicate d '.' else error (show ("duration_recip_pp",x,d,m,r)) + +-- * 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 = 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.."] +-- > 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 '.' + m' = case (numerator m,denominator m) of + (1,1) -> "" + (i,j) -> '/' : show i ++ ":" ++ show j + in case whole_note_division_letter_pp x of + Just x' -> Just (x' : d' ++ m') + _ -> Nothing diff --git a/Music/Theory/Duration/Annotation.hs b/Music/Theory/Duration/Annotation.hs --- a/Music/Theory/Duration/Annotation.hs +++ b/Music/Theory/Duration/Annotation.hs @@ -3,11 +3,12 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import qualified Data.Traversable as T {- base -} import Data.Tree {- containers -} +import qualified Music.Theory.List as L {- hmt-base -} + import Music.Theory.Duration -import Music.Theory.Duration.RQ +import Music.Theory.Duration.Rq -- | Standard music notation durational model annotations data D_Annotation = Tie_Right @@ -57,58 +58,12 @@ 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) in zipWith jn (map fn x) ts --- | Transform predicates into 'Ordering' predicate such that if /f/ --- holds then 'LT', if /g/ holds then 'GT' else 'EQ'. --- --- > map (begin_end_cmp (== '{') (== '}')) "{a}" == [LT,EQ,GT] -begin_end_cmp :: (t -> Bool) -> (t -> Bool) -> t -> Ordering -begin_end_cmp f g x = if f x then LT else if g x then GT else EQ - --- | Variant of 'begin_end_cmp', predicates are constructed by '=='. --- --- > map (begin_end_cmp_eq '{' '}') "{a}" == [LT,EQ,GT] -begin_end_cmp_eq :: Eq t => t -> t -> t -> Ordering -begin_end_cmp_eq p q = begin_end_cmp (== p) (== q) - --- | 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" --- > ;t = group_tree (begin_end_cmp_eq '{' '}') l} --- > in catMaybes (flatten t) == l --- --- > let d = putStrLn . drawTree . fmap show --- > in d (group_tree (begin_end_cmp_eq '(' ')') "a(b(cd)ef)ghi") -group_tree :: (a -> Ordering) -> [a] -> Tree (Maybe a) -group_tree f = - let unit e = Node (Just e) [] - nil = Node Nothing [] - insert_e (Node t l) e = Node t (e:l) - reverse_n (Node t l) = Node t (reverse l) - push (r,z) e = case z of - h:z' -> (r,insert_e h (unit e) : z') - [] -> (unit e : r,[]) - open (r,z) = (r,nil:z) - 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 - [] -> Node Nothing (reverse (fst st)) - e:x' -> case f e of - LT -> go (push (open st) e) x' - EQ -> go (push st e) x' - GT -> go (close (push st e)) x' - in go ([],[]) - -- | Group tuplets into a 'Tree'. Branch nodes have label 'Nothing', -- leaf nodes label 'Just' 'Duration_A'. -- @@ -121,9 +76,7 @@ -- > ,(q,[])] -- > in catMaybes (flatten (da_group_tuplets d)) == d da_group_tuplets :: [Duration_A] -> Tree (Maybe Duration_A) -da_group_tuplets = - let f = begin_end_cmp da_begins_tuplet da_ends_tuplet - in group_tree f +da_group_tuplets = L.group_tree (da_begins_tuplet,da_ends_tuplet) -- | Variant of 'break' that places separator at left. -- @@ -165,22 +118,11 @@ in Right (d : t) : da_group_tuplets_nn x'' else Left d : da_group_tuplets_nn x' --- | Keep right variant of 'zipWith', 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 [] - -- | Keep right variant of 'zip', unused rhs values are returned. -- -- > zip_kr [1..4] ['a'..'f'] == ([(1,'a'),(2,'b'),(3,'c'),(4,'d')],"ef") zip_kr :: [a] -> [b] -> ([(a,b)],[b]) -zip_kr = zip_with_kr (,) +zip_kr = L.zip_with_kr (,) -- | 'zipWith' variant that adopts the shape of the lhs. -- @@ -192,31 +134,9 @@ case (p,q) of (e:p',i:q') -> case e of Left j -> Left (f j i) : nn_reshape f p' q' - Right j -> let (j',q'') = zip_with_kr f j q + Right j -> let (j',q'') = L.zip_with_kr f j q in Right j' : nn_reshape f p' q'' _ -> [] - --- | Replace elements at 'Traversable' with result of joining with --- elements from list. -adopt_shape :: T.Traversable t => (a -> b -> c) -> [b] -> t a -> t c -adopt_shape jn l = - let f (i:j) k = (j,jn k i) - f [] _ = error "adopt_shape: rhs ends" - in snd . T.mapAccumL f l - --- | Variant of 'adopt_shape' that considers only 'Just' elements at --- 'Traversable'. --- --- > let {s = "a(b(cd)ef)ghi" --- > ;t = group_tree (begin_end_cmp_eq '(' ')') s} --- > in adopt_shape_m (,) [1..13] t -adopt_shape_m :: T.Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> t (Maybe c) -adopt_shape_m jn l = - let f (i:j) k = case k of - Nothing -> (i:j,Nothing) - Just k' -> (j,Just (jn k' i)) - f [] _ = error "adopt_shape_m: rhs ends" - in snd . T.mapAccumL f l -- | Does /a/ have 'Tie_Left' and 'Tie_Right'? d_annotated_tied_lr :: [D_Annotation] -> (Bool,Bool) diff --git a/Music/Theory/Duration/CT.hs b/Music/Theory/Duration/CT.hs deleted file mode 100644 --- a/Music/Theory/Duration/CT.hs +++ /dev/null @@ -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..]) dv - f (p,rq,(g,du)) = - let nm = if p == 1 - then case mk of - Nothing -> CT_Start du - Just _ -> CT_Mark du - else if pr == Just () - then CT_Pre du - else if g == 1 then CT_Edge du else CT_Normal du - in (du * (60 / ct_tempo_at sq rq),nm) - in map f (zip3 [1..] mrq dv') - --- | Click track definition. -data CT = CT {ct_len :: Int - ,ct_ts :: [(Measure,T.Rational_Time_Signature)] - ,ct_mark :: [(Measure,Char)] - ,ct_tempo :: T.Lseq (Measure,Pulse) T.RQ - ,ct_count :: (T.RQ,Int)} - deriving Show - --- | Initial tempo, if given. -ct_tempo0 :: CT -> Maybe T.RQ -ct_tempo0 ct = - case ct_tempo ct of - (((1,1),_),n):_ -> Just n - _ -> Nothing - --- | Erroring variant. -ct_tempo0_err :: CT -> T.RQ -ct_tempo0_err = fromMaybe (error "ct_tempo0") . ct_tempo0 - --- > import Music.Theory.Duration.CT --- > import Music.Theory.Time.Seq --- > let ct = CT 2 [(1,[(3,8),(2,4)])] [(1,'a')] [(((1,0),T.None),60)] undefined --- > ct_measures ct -ct_measures :: CT -> [T.Dseq Rational CT_Node] -ct_measures (CT n ts mk tm _) = - let f msg sq = let (m,v) = unzip sq - in if m == [1 .. n] - then v - else error (show ("ct_measures",msg,sq,m,v,n)) - msr = zip4 - (f "ts" (zip [1..] (ct_rq n ts))) - (f "mk" (ct_mark_seq n mk)) - (f "pre-mk" (ct_pre_mark_seq n mk)) - (f "dv" (ct_dv_seq n ts)) - in map (ct_measure (ct_tempo_lseq_rq (ct_mdv_seq n ts) tm)) msr - -ct_dseq' :: CT -> T.Dseq Rational CT_Node -ct_dseq' = concat . ct_measures - -ct_dseq :: CT -> T.Dseq Double CT_Node -ct_dseq = T.dseq_tmap fromRational . ct_dseq' - --- * Indirect - -ct_rq_measure :: [[T.RQ]] -> T.RQ -> Maybe Measure -ct_rq_measure sq rq = fmap fst (find ((rq `elem`) . snd) (zip [1..] sq)) - -ct_rq_mp :: [[T.RQ]] -> T.RQ -> Maybe (Measure,Pulse) -ct_rq_mp sq rq = - let f (m,l) = (m,fromMaybe (error "ct_rq_mp: ix") (findIndex (== rq) l) + 1) - in fmap f (find ((rq `elem`) . snd) (zip [1..] sq)) - -ct_rq_mp_err :: [[T.RQ]] -> T.RQ -> (Measure, Pulse) -ct_rq_mp_err sq = fromMaybe (error "ct_rq_mp") . ct_rq_mp sq - -ct_mp_to_rq :: [[T.RQ]] -> [((Measure,Pulse),t)] -> [(T.RQ,t)] -ct_mp_to_rq sq = map (\(mp,c) -> (ct_mp_lookup sq mp,c)) diff --git a/Music/Theory/Duration/ClickTrack.hs b/Music/Theory/Duration/ClickTrack.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/ClickTrack.hs @@ -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)) diff --git a/Music/Theory/Duration/Hollos2014.hs b/Music/Theory/Duration/Hollos2014.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/Hollos2014.hs @@ -0,0 +1,104 @@ +-- | "Creating Rhythms" by Stefan Hollos and J. Richard Hollos +-- +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 +-- +-- +-- > 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. +-- +-- > 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 diff --git a/Music/Theory/Duration/Name.hs b/Music/Theory/Duration/Name.hs --- a/Music/Theory/Duration/Name.hs +++ b/Music/Theory/Duration/Name.hs @@ -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 diff --git a/Music/Theory/Duration/Name/Abbreviation.hs b/Music/Theory/Duration/Name/Abbreviation.hs --- a/Music/Theory/Duration/Name/Abbreviation.hs +++ b/Music/Theory/Duration/Name/Abbreviation.hs @@ -1,8 +1,9 @@ --- | 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 --- dotted 'eighth_note'. +-- dotted 'eighth_note'. The prefix is @_@ not @d@ since @d4@ etc. are +-- also note names. -- -- > zipWith duration_compare_meq [e,e,e,e'] [e,s,q,e] == [EQ,GT,LT,GT] -- > zipWith sum_dur [e,q,q'] [e,e,e] == [Just q,Just q',Just h] diff --git a/Music/Theory/Duration/RQ.hs b/Music/Theory/Duration/RQ.hs deleted file mode 100644 --- a/Music/Theory/Duration/RQ.hs +++ /dev/null @@ -1,187 +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 -import Music.Theory.Duration.Name - --- | Rational Quarter-Note -type RQ = Rational - --- | 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 = - case (numerator x,denominator x) of - (1,8) -> Just thirtysecond_note - (3,16) -> Just dotted_thirtysecond_note - (1,4) -> Just sixteenth_note - (3,8) -> Just dotted_sixteenth_note - (1,2) -> Just eighth_note - (3,4) -> Just dotted_eighth_note - (1,1) -> Just quarter_note - (3,2) -> Just dotted_quarter_note - (2,1) -> Just half_note - (3,1) -> Just dotted_half_note - (7,2) -> Just double_dotted_half_note - (4,1) -> Just whole_note - (6,1) -> Just dotted_whole_note - (8,1) -> Just breve - (12,1) -> Just dotted_breve - _ -> Nothing - --- | 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 :: Integer -> 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] == [3/2,7/4] -rq_apply_dots :: RQ -> Integer -> 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' diff --git a/Music/Theory/Duration/RQ/Division.hs b/Music/Theory/Duration/RQ/Division.hs deleted file mode 100644 --- a/Music/Theory/Duration/RQ/Division.hs +++ /dev/null @@ -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) diff --git a/Music/Theory/Duration/RQ/Tied.hs b/Music/Theory/Duration/RQ/Tied.hs deleted file mode 100644 --- a/Music/Theory/Duration/RQ/Tied.hs +++ /dev/null @@ -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 diff --git a/Music/Theory/Duration/Rq.hs b/Music/Theory/Duration/Rq.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/Rq.hs @@ -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 + diff --git a/Music/Theory/Duration/Rq/Division.hs b/Music/Theory/Duration/Rq/Division.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/Rq/Division.hs @@ -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) diff --git a/Music/Theory/Duration/Rq/Tied.hs b/Music/Theory/Duration/Rq/Tied.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Duration/Rq/Tied.hs @@ -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 diff --git a/Music/Theory/Duration/Sequence/Notate.hs b/Music/Theory/Duration/Sequence/Notate.hs --- a/Music/Theory/Duration/Sequence/Notate.hs +++ b/Music/Theory/Duration/Sequence/Notate.hs @@ -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,54 +17,31 @@ -- 5. Ascribe values to notated durations, see 'ascribe'. module Music.Theory.Duration.Sequence.Notate where -import Control.Applicative {- base -} -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 @@ -76,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 @@ -96,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 @@ -104,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 @@ -161,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 @@ -187,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) -> @@ -215,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 @@ -275,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] @@ -288,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) @@ -302,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) . @@ -386,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 @@ -449,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)) @@ -489,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)) @@ -534,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) @@ -543,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 @@ -642,10 +617,18 @@ 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 +-- | Run simplifier until it reaches a fix-point, or for at most 'limit' passes. +m_simplify_fix :: Int -> Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A] +m_simplify_fix limit p ts d = + let d' = m_simplify p ts d + in if d == d' || limit == 1 + then d' + else m_simplify_fix (limit - 1) p ts d' + -- | Pulse simplifier predicate, which is 'const' 'True'. p_simplify_rule :: Simplify_P p_simplify_rule = const True @@ -660,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'. @@ -674,23 +657,22 @@ > ts_p = [[1/2,1,1/2],[1/2,1]] > rq = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3] > sr x = T.default_rule [] x -> in T.notate_rqp sr ts (Just ts_p) rq +> in T.notate_rqp 4 sr ts (Just ts_p) rq -} -notate_rqp :: Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> +notate_rqp :: Int -> Simplify_P -> [Time_Signature] -> Maybe [[Rq]] -> [Rq] -> Either String [[Duration_A]] -notate_rqp r ts ts_p x = do +notate_rqp limit r ts ts_p x = do let ts_p' = fromMaybe (map ts_divisions ts) ts_p mm <- to_divisions_rq ts_p' x dd <- mm_notate mm - return (zipWith (m_simplify r) ts dd) + return (zipWith (m_simplify_fix limit r) ts dd) -- | Variant of 'notate_rqp' without pulse divisions (derive). -- --- > notate (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6] -notate :: Simplify_P -> [Time_Signature] -> [RQ] -> - Either String [[Duration_A]] -notate r ts x = notate_rqp r ts Nothing x +-- > 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 = notate_rqp limit r ts Nothing -- * Ascribe @@ -772,17 +754,17 @@ in r : mm_ascribe mm' x' -- | 'mm_ascribe of 'notate'. -notate_mm_ascribe :: Show a => [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 r ts rqp d p = - let n = notate_rqp (default_rule r) ts rqp d +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 => [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 +notate_mm_ascribe_err = either error id .::::: notate_mm_ascribe -- | Group elements as /chords/ where a chord element is indicated by -- the given predicate. diff --git a/Music/Theory/Dynamic_Mark.hs b/Music/Theory/Dynamic_Mark.hs --- a/Music/Theory/Dynamic_Mark.hs +++ b/Music/Theory/Dynamic_Mark.hs @@ -4,57 +4,71 @@ import Data.Char {- base -} import Data.List {- base -} import Data.Maybe {- base -} +import Text.Read {- base -} -import qualified Music.Theory.List as T +import qualified Music.Theory.List as T {- hmt -} -- | Enumeration of dynamic mark symbols. -data Dynamic_Mark_T = Niente - | PPPPP | PPPP | PPP | PP | P | MP - | MF | F | FF | FFF | FFFF | FFFFF - | FP | SF | SFP | SFPP | SFZ | SFFZ - deriving (Eq,Ord,Enum,Bounded,Show) +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) --- | 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 +{- | Case insensitive reader for 'Dynamic_Mark'. + +> 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,Eq 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) --- | --- --- > import Sound.SC3.Plot --- > plotTable [map (ampmidid 20) [0 .. 127],map (ampmidid 60) [0 .. 127]] +{- | + +> 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) @@ -62,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 @@ -89,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 @@ -117,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) @@ -129,48 +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 @@ -181,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 diff --git a/Music/Theory/Either.hs b/Music/Theory/Either.hs deleted file mode 100644 --- a/Music/Theory/Either.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | Either -module Music.Theory.Either where - --- | Maybe 'Left' of 'Either'. -fromLeft :: Either a b -> Maybe a -fromLeft e = - case e of - Left x -> Just x - _ -> Nothing - --- | Maybe 'Right' of 'Either'. -fromRight :: Either a b -> Maybe b -fromRight e = - case e of - Right x -> Just x - _ -> Nothing diff --git a/Music/Theory/Function.hs b/Music/Theory/Function.hs deleted file mode 100644 --- a/Music/Theory/Function.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | "Data.Function" related functions. -module Music.Theory.Function where - --- * Predicate composition. - --- | '&&' of predicates. -predicate_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool -predicate_and f g x = f x && g x - --- | 'all' of predicates. --- --- > let r = [False,False,True,False,True,False] --- > in map (predicate_all [(> 0),(< 5),even]) [0..5] == r -predicate_all :: [t -> Bool] -> t -> Bool -predicate_all p x = all id (map ($ x) p) - --- | '||' of predicates. -predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool -predicate_or f g x = f x || g x - --- | 'any' of predicates. --- --- > let r = [True,False,True,False,True,True] --- > in map (predicate_any [(== 0),(== 5),even]) [0..5] == r -predicate_any :: [t -> Bool] -> t -> Bool -predicate_any p x = any id (map ($ x) p) - --- * Function composition. - --- . is infixr 9, this allows f . g .: h -infixr 8 .:, .::, .:::, .::::, .::::: - --- | 'fmap' '.' 'fmap', ie. @(t -> c) -> (a -> b -> t) -> a -> b -> c@. -(.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) -(.:) = fmap . fmap - --- | 'fmap' '.' '.:', ie. @(t -> d) -> (a -> b -> c -> t) -> a -> b -> c -> d@. -(.::) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b)) -(.::) = fmap . (.:) - --- | 'fmap' '.' '.::'. -(.:::) :: (Functor f, Functor g, Functor h,Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b))) -(.:::) = fmap . (.::) - --- | 'fmap' '.' '.:::'. -(.::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b)))) -(.::::) = fmap . (.:::) - --- | 'fmap' '.' '.::::'. -(.:::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j,Functor k) => (a -> b) -> f (g (h (i (j (k a))))) -> f (g (h (i (j (k b))))) -(.:::::) = fmap . (.::::) - diff --git a/Music/Theory/Gamelan.hs b/Music/Theory/Gamelan.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Gamelan.hs @@ -0,0 +1,372 @@ +-- | Gamelan instruments and pitch structures. +module Music.Theory.Gamelan where + +import Data.Char {- base -} +import Data.Function {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +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.Pitch as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuning.Et as T {- hmt-diagrams -} + +-- | 'fromJust' with error message. +fromJust_err :: String -> Maybe a -> a +fromJust_err err = fromMaybe (error err) + +-- | 'approxRational' of 0.01. +near_rat :: Double -> Rational +near_rat = flip approxRational 0.01 + +-- * Gamelan + +-- | Enumeration of gamelan instrument families. +data Instrument_Family + = Bonang + | Gambang + | Gender + | Gong + | Saron + deriving (Enum,Bounded,Eq,Ord,Show,Read) + +-- | Universe +instrument_family_set :: [Instrument_Family] +instrument_family_set = T.enum_univ + +-- | Enumeration of Gamelan instruments. +data Instrument_Name + = Bonang_Barung -- ^ Bonang Barung (horizontal gong, middle) + | Bonang_Panerus -- ^ Bonang Panerus (horizontal gong, high) + | Gambang_Kayu -- ^ Gambang Kayu (wooden key&resonator) + | Gender_Barung -- ^ Gender Barung (key&resonator, middle) + | Gender_Panerus -- ^ Gender Panembung (key&resonator, high) + | Gender_Panembung -- ^ Gender Panembung, Slenthem (key&resonator, low) + | Gong_Ageng -- ^ Gong Ageng (hanging gong, low) + | Gong_Suwukan -- ^ Gong Suwukan (hanging gong, middle) + | Kempul -- ^ Kempul (hanging gong, middle) + | Kempyang -- ^ Kempyang (horizontal gong, high) + | Kenong -- ^ Kenong (horizontal gong, low) + | Ketuk -- ^ Ketuk, Kethuk (horizontal gong, middle) + | Saron_Barung -- ^ Saron Barung, Saron (key, middle) + | Saron_Demung -- ^ Saron Demung, Demung (key, low) + | Saron_Panerus -- ^ Saron Panerus, Peking (key, high) + deriving (Enum,Bounded,Eq,Ord,Show,Read) + +instrument_family :: Instrument_Name -> Instrument_Family +instrument_family nm = + case nm of + Bonang_Barung -> Bonang + Bonang_Panerus -> Bonang + Gambang_Kayu -> Gambang + Gender_Barung -> Gender + Gender_Panerus -> Gender + Gender_Panembung -> Gender + Gong_Ageng -> Gong + Gong_Suwukan -> Gong + Kempul -> Gong + Kempyang -> Gong + Kenong -> Gong + Ketuk -> Gong + Saron_Barung -> Saron + Saron_Demung -> Saron + Saron_Panerus -> Saron + +instrument_name_pp :: Instrument_Name -> String +instrument_name_pp = + let f c = if c == '_' then ' ' else c + in map f . show + +-- | 'Clef' appropriate for 'Instrument_Name'. +instrument_name_clef :: Integral i => Instrument_Name -> T.Clef i +instrument_name_clef nm = + case nm of + Bonang_Barung -> T.Clef T.Treble 0 + Bonang_Panerus -> T.Clef T.Treble 1 + Gambang_Kayu -> T.Clef T.Treble 0 + Gender_Barung -> T.Clef T.Treble 0 + Gender_Panerus -> T.Clef T.Treble 1 + Gender_Panembung -> T.Clef T.Bass 0 + Gong_Ageng -> T.Clef T.Bass 0 + Gong_Suwukan -> T.Clef T.Bass 0 + Kempul -> T.Clef T.Bass 0 + Kempyang -> T.Clef T.Treble 1 + Kenong -> T.Clef T.Treble 0 + Ketuk -> T.Clef T.Alto 0 + Saron_Barung -> T.Clef T.Treble 0 + Saron_Demung -> T.Clef T.Treble 0 + Saron_Panerus -> T.Clef T.Treble 1 + +instrument_name_clef_plain :: Integral i => Instrument_Name -> T.Clef i +instrument_name_clef_plain = T.clef_zero . instrument_name_clef + +-- | Enumeration of Gamelan scales. +data Scale = Pelog | Slendro deriving (Enum,Eq,Ord,Show,Read) + +-- | Octaves are zero-indexed and may be negative. +type Octave = Integer + +-- | Degrees are one-indexed. +type Degree = Integer + +-- | Frequency in hertz. +type Frequency = Double + +-- | A text annotation. +type Annotation = String + +-- | 'Octave' and 'Degree'. +data Pitch = Pitch {pitch_octave :: Octave + ,pitch_degree :: Degree} + deriving (Eq,Ord,Show) + +-- | Octaves are written as repeated @-@ or @+@, degrees are printed ordinarily. +-- +-- > map pitch_pp_ascii (zipWith Pitch [-2 .. 2] [1 .. 5]) == ["--1","-2","3","+4","++5"] +pitch_pp_ascii :: Pitch -> String +pitch_pp_ascii (Pitch o d) = + let d' = intToDigit (fromIntegral d) + o' = if o < 0 + then genericReplicate (abs o) '-' + else genericReplicate o '+' + in o' ++ [d'] + +pitch_pp_duple :: Pitch -> String +pitch_pp_duple (Pitch o d) = printf "(%d,%d)" o d + +-- | 'Scale' and 'Pitch'. +data Note = Note {note_scale :: Scale + ,note_pitch :: Pitch} + deriving (Eq,Show) + +-- | 'pitch_degree' of 'note_pitch'. +note_degree :: Note -> Degree +note_degree = pitch_degree . note_pitch + +-- | It is an error to compare notes from different scales. +note_compare :: Note -> Note -> Ordering +note_compare (Note s1 p1) (Note s2 p2) = + if s1 /= s2 + then error "note_compare?" + else compare p1 p2 + +-- | Orderable if scales are equal. +instance Ord Note where compare = note_compare + +-- | Ascending sequence of 'Note' for 'Scale' from /p1/ to /p2/ inclusive. +note_range_elem :: Scale -> Pitch -> Pitch -> [Note] +note_range_elem scl p1@(Pitch o1 _d1) p2@(Pitch o2 _d2) = + let univ = [Note scl (Pitch o d) | o <- [o1 .. o2], d <- scale_degrees scl] + in filter (\n -> note_pitch n >= p1 && note_pitch n <= p2) univ + +-- | Ascending sequence of 'Note' from /n1/ to /n2/ inclusive. +-- +-- > note_gamut_elem (Note Slendro (Pitch 0 5)) (Note Slendro (Pitch 1 2)) +note_gamut_elem :: Note -> Note -> [Note] +note_gamut_elem (Note s1 p1) (Note s2 p2) = + if s1 /= s2 + then error "note_gamut_elem?" + else note_range_elem s1 p1 p2 + +data Tone t = Tone {tone_instrument_name :: Instrument_Name + ,tone_note :: Maybe Note + ,tone_frequency :: Maybe Frequency + ,tone_annotation :: Maybe t} + deriving (Eq,Show) + +tone_frequency_err :: Tone t -> Frequency +tone_frequency_err = fromJust_err "tone_frequency" . tone_frequency + +-- | Orderable if frequency is given. +instance Eq t => Ord (Tone t) where compare = tone_compare_frequency + +-- | Constructor for 'Tone' without /frequency/ or /annotation/. +plain_tone :: Instrument_Name -> Scale -> Octave -> Degree -> Tone t +plain_tone nm sc o d = Tone nm (Just (Note sc (Pitch o d))) Nothing Nothing + +-- | Tones are considered /equivalent/ if they have the same +-- 'Instrument_Name' and 'Note'. +tone_equivalent :: Tone t -> Tone t -> Bool +tone_equivalent p q = + let Tone nm nt _ _ = p + Tone nm' nt' _ _ = q + in nm == nm' && nt == nt' + +tone_24et_pitch :: Tone t -> Maybe T.Pitch +tone_24et_pitch = + 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_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 + +tone_fmidi :: Tone t -> Double +tone_fmidi = T.cps_to_fmidi . tone_frequency_err + +-- | Fractional (rational) 24-et midi note number of 'Tone'. +tone_24et_fmidi :: Tone t -> Rational +tone_24et_fmidi = near_rat . T.pitch_to_fmidi . tone_24et_pitch' + +tone_12et_pitch :: Tone t -> Maybe T.Pitch +tone_12et_pitch = + 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_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 + +-- | Fractional (rational) 24-et midi note number of 'Tone'. +tone_12et_fmidi :: Tone t -> Rational +tone_12et_fmidi = near_rat . T.pitch_to_fmidi . tone_12et_pitch' + +tone_family :: Tone t -> Instrument_Family +tone_family = instrument_family . tone_instrument_name + +tone_in_family :: Instrument_Family -> Tone t -> Bool +tone_in_family c t = tone_family t == c + +select_tones :: Instrument_Family -> [Tone t] -> [Maybe (Tone t)] +select_tones c = + let f t = if tone_family t == c then Just t else Nothing + in map f + +-- | Specify subset as list of families and scales. +type Tone_Subset = ([Instrument_Family],[Scale]) + +-- | Extract subset of 'Tone_Set'. +tone_subset :: Tone_Subset -> Tone_Set t -> Tone_Set t +tone_subset (fm,sc) = + let f t = tone_family t `elem` fm && + fromJust_err "tone_subset" (tone_scale t) `elem` sc + in filter f + +data Instrument = Instrument {instrument_name :: Instrument_Name + ,instrument_scale :: Maybe Scale + ,instrument_pitches :: Maybe [Pitch] + ,instrument_frequencies :: Maybe [Frequency]} + deriving (Eq,Show) + +type Tone_Set t = [Tone t] +type Tone_Group t = [Tone_Set t] +type Gamelan = [Instrument] + +tone_scale :: Tone t -> Maybe Scale +tone_scale = fmap note_scale . tone_note + +tone_pitch :: Tone t -> Maybe Pitch +tone_pitch = fmap note_pitch . tone_note + +tone_degree :: Tone t -> Maybe Degree +tone_degree = fmap pitch_degree . tone_pitch + +tone_degree' :: Tone t -> Degree +tone_degree' = fromJust_err "tone_degree" . tone_degree + +tone_octave :: Tone t -> Maybe Octave +tone_octave = fmap pitch_octave . tone_pitch + +tone_class :: Tone t -> (Instrument_Name,Maybe Scale) +tone_class t = (tone_instrument_name t,tone_scale t) + +instrument_class :: Instrument -> (Instrument_Name,Maybe Scale) +instrument_class i = (instrument_name i,instrument_scale i) + +tone_class_p :: (Instrument_Name, Scale) -> Tone t -> Bool +tone_class_p (nm,sc) t = + tone_instrument_name t == nm && + tone_scale t == Just sc + +tone_family_class_p :: (Instrument_Family,Scale) -> Tone t -> Bool +tone_family_class_p (fm,sc) t = + instrument_family (tone_instrument_name t) == fm && + tone_scale t == Just sc + +-- | Given a 'Tone_Set', find those 'Tone's that are within 'T.Cents' of 'Frequency'. +tone_set_near_frequency :: Tone_Set t -> T.Cents -> Frequency -> Tone_Set t +tone_set_near_frequency t k n = + let near i = abs (T.cps_difference_cents i n) <= k + near_t i = maybe False near (tone_frequency i) + in filter near_t t + +-- | 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` (fromMaybe 0 . tone_frequency) + +-- | If all /f/ of /a/ are 'Just' /b/, then 'Just' /[b]/, else +-- 'Nothing'. +map_maybe_uniform :: (a -> Maybe b) -> [a] -> Maybe [b] +map_maybe_uniform f x = + let x' = map f x + in if any isNothing x' then Nothing else Just (catMaybes x') + +instrument :: Tone_Set t -> Instrument +instrument c = + let sf = fmap note_scale . tone_note + pf = fmap note_pitch . tone_note + pm = map_maybe_uniform pf c + fm = map_maybe_uniform tone_frequency c + (p,f) = case (pm,fm) of + (Just i,Just j) -> let (i',j') = unzip (sort (zip i j)) + in (Just i',Just j') + _ -> (pm,fm) + in case c of + t:_ -> Instrument (tone_instrument_name t) (sf t) p f + [] -> undefined + +instruments :: Tone_Set t -> [Instrument] +instruments c = + let c' = sortBy (compare `on` tone_instrument_name) c + c'' = groupBy ((==) `on` tone_class) c' + in map instrument c'' + +instrument_gamut :: Instrument -> Maybe (Pitch,Pitch) +instrument_gamut = + let f p = (head p,last p) + in fmap f . instrument_pitches + +-- | Pelog has seven degrees, numbered one to seven. +-- Slendro has five degrees, numbered one to six excluding four. +-- +-- > map scale_degrees [Pelog,Slendro] == [[1,2,3,4,5,6,7],[1,2,3,5,6]] +scale_degrees :: Scale -> [Degree] +scale_degrees s = + case s of + Pelog -> [1..7] + Slendro -> [1,2,3,5,6] + +-- | Zero based index of scale degree, or Nothing. +-- +-- > degree_index Slendro 4 == Nothing +-- > degree_index Pelog 4 == Just 3 +degree_index :: Scale -> Degree -> Maybe Int +degree_index s d = elemIndex d (scale_degrees s) + +-- * Tone set + +tone_set_gamut :: Tone_Set t -> Maybe (Pitch,Pitch) +tone_set_gamut g = + case mapMaybe (fmap note_pitch . tone_note) g of + [] -> Nothing + p -> Just (minimum p,maximum p) + +tone_set_instrument :: Tone_Set t -> (Instrument_Name,Maybe Scale) -> Tone_Set t +tone_set_instrument db (i,s) = + let f t = tone_class t == (i,s) + in filter f db diff --git a/Music/Theory/Graph/Deacon_1934.hs b/Music/Theory/Graph/Deacon_1934.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Deacon_1934.hs @@ -0,0 +1,133 @@ +-- | Geometrical Drawings +-- +-- A. Bernard Deacon and Camilla H. Wedgwood. “Geometrical Drawings +-- from Malekula and Other Islands of the New Hebrides”. The Journal +-- of the Royal Anthropological Institute of Great Britain and +-- 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-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 -} + +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 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.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) + +-- * E +g1 :: G +g1 = + let c1 = words "A1 B2 A3 B4 C3 B2 C1 D2 C3 D4 D3 D2 D1 C2 D3 C4 B3 C2 B1 A2 B3 A4 A3 A2 A1" + o1 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")] + in (T.adj2 1 c1,o1,"E") + +-- * D +g2 :: G +g2 = + let c2' = words "B3 C2 = C3 B2 A1 = A2 B1 C2 = C1 B2 A3 = A2 B3 C3 C2 B2 B3 ~ C3 ~ C2 C1 == C3 C2 C1 B1 B2 C2 ~ C1 ~ B1 A1 C1 B1 A1 A2 B2 B1 ~ A1 ~ A2 A3 == A1 A2 A3 B3 B2 A2 ~ A3 ~ B3 C3 C3 ~~ C1 ~~ A1 ~~ A3 A3 B3" + c2 = filter T.is_cell_ref c2' + o2 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c2,o2,"D") + +-- * A +g4 :: G +g4 = + let c4' = words "B1 C2 C3 B3 B2 C2 ~~ C3 C2 ~~ C1 C2 C2 B3 A3 A2 B2 B3 ~~ A3 B3 ~~ C3 B3 B3 A2 A1 B1 B2 A2 ~~ A1 A2 ~~ A3 A2 A2 B1 C1 C2 B2 B1 ~~ C1 B1 ~~ A1 B1 B1" + c4 = filter T.is_cell_ref c4' + o4 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c4,o4,"A") + +g6 :: G +g6 = + let c6' = words "B1 C2 B2 C1 B1 A2 B2 A1 B1 B2 B3 B3 B3 B3 B2 B1 B0 B0 B0 B0 B1 C1 ~~~ C2 B2 B2 B2 A2 ~~~ A1 B1 B1 B1" + c6 = filter T.is_cell_ref c6' + o6 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c6,o6,"B") + +g8 :: G +g8 = + let c8' = words "C2 B1 B1 A2 ~ (04) B1 B2 B3 ~ (08) C2 B3 B3 A2 ~ (13) B3 B2 A2 (17) A3 A3 B2 C1 C1 C2 B2 B1 ~ (23) C2 B2 A2 A1 A1 B2 C3 C3 C2" + c8 = filter T.is_cell_ref c8' + o8 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")] + in (T.adj2 1 c8,o8,"C") + +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 = 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") + +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 = 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")] + in (e10,o10,"G") + +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 = 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")] + in (e11,o11,"H") + +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 = 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")] + in (e12,o12,"I") + +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 = 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")] + in (e13,o13,"J") + +g_all :: [G] +g_all = [g1,g2,g4,g6,g8,g9,g10,g11,g12,g13] + +-- G = unlabeled, GL = labeled +-- GC = collated, GF = filtered (unique edges) +-- GD = directed +wr :: G -> IO () +wr (e,o,nm) = do + let mk_nm ty = "/home/rohan/sw/hmt/data/dot/deacon/" ++ nm ++ "_" ++ ty ++ ".dot" + wr_f ty g = writeFile (mk_nm ty) (unlines g) + wr_f "G" (gen_graph_ul o id e) + wr_f "GL" (gen_graph o (T.gr_pp_label id show) (T.e_label_seq e)) + wr_f "GC" (gen_graph o (T.gr_pp_label id T.br_csl_pp) (T.e_collate_normalised_l (T.e_label_seq e))) + wr_f "GF" (gen_graph_ul o id (nub (map T.t2_sort e))) + wr_f "GD" (gen_digraph o (T.gr_pp_label id T.br_csl_pp) (T.e_collate_normalised_l (T.e_label_seq e))) +{- + let o' = ("graph:layout","fdp") : o + wr_f "GC_" (gen_graph o' T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e))) +-} + +wr_all :: IO () +wr_all = mapM_ wr g_all diff --git a/Music/Theory/Graph/Dot.hs b/Music/Theory/Graph/Dot.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Dot.hs @@ -0,0 +1,213 @@ +-- | Graph (dot) functions. +module Music.Theory.Graph.Dot where + +import Control.Monad {- base -} +import Data.Char {- base -} +import Data.List {- base -} +import System.FilePath {- filepath -} +import System.Process {- process -} + +import qualified Data.Graph.Inductive.Graph as G {- fgl -} + +import qualified 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 -} + +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 = + case s of + c0:s' -> p c0 && all q s' && r s + [] -> False + +-- | Symbol rule. +-- +-- > map is_symbol ["sym","Sym2","3sym","1",""] == [True,True,False,False,False] +is_symbol :: String -> Bool +is_symbol = s_classify isAlpha isAlphaNum (const True) + +-- | Number rule. +-- +-- > 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 ('.' ==)) + +-- | Quote /s/ if 'is_symbol' or 'is_number'. +-- +-- > map maybe_quote ["abc","a b c","12","12.3"] == ["abc","\"a b c\"","12","12.3"] +maybe_quote :: String -> String +maybe_quote s = if is_symbol s || is_number s then s else concat ["\"",s,"\""] + +-- * Attr/Key + +type Dot_Key = String +type Dot_Value = String +type Dot_Attr = (Dot_Key,Dot_Value) + +-- | Format 'Dot_Attr'. +dot_attr_pp :: Dot_Attr -> String +dot_attr_pp (lhs,rhs) = concat [lhs,"=",maybe_quote rhs] + +-- | Format sequence of Dot_Attr. +-- +-- > dot_attr_seq_pp [("layout","neato"),("epsilon","0.0001")] +dot_attr_seq_pp :: [Dot_Attr] -> String +dot_attr_seq_pp opt = + if null opt + then "" + else concat ["[",intercalate "," (map dot_attr_pp opt),"]"] + +-- | Merge attributes, left-biased. +dot_attr_ext :: [Dot_Attr] -> [Dot_Attr] -> [Dot_Attr] +dot_attr_ext = List.assoc_merge + +-- | graph|node|edge +type Dot_Type = String + +-- | (type,[attr]) +type Dot_Attr_Set = (Dot_Type,[Dot_Attr]) + +-- | Format Dot_Attr_Set. +-- +-- > a = ("graph",[("layout","neato"),("epsilon","0.0001")]) +-- > dot_attr_set_pp a == "graph [layout=neato,epsilon=0.0001]" +dot_attr_set_pp :: Dot_Attr_Set -> String +dot_attr_set_pp (ty,opt) = concat [ty," ",dot_attr_seq_pp opt] + +-- | type:attr (type = graph|node|edge) +type Dot_Meta_Key = String + +type Dot_Meta_Attr = (Dot_Meta_Key,Dot_Value) + +-- | Keys are given as "type:attr". +-- +-- > dot_key_sep "graph:layout" == ("graph","layout") +dot_key_sep :: Dot_Meta_Key -> (Dot_Type,Dot_Key) +dot_key_sep = List.split_on_1_err ":" + +-- | Collate Dot_Key attribute set to Dot_Attr_Set. +dot_attr_collate :: [Dot_Meta_Attr] -> [Dot_Attr_Set] +dot_attr_collate opt = + let f (k,v) = let (ty,nm) = dot_key_sep k in (ty,(nm,v)) + c = map f opt + in List.collate c + +-- | Default values for default meta-keys. +-- +-- > k = dot_attr_def ("neato","century schoolbook",10,"plaintext") +-- > map dot_attr_set_pp (dot_attr_collate k) +dot_attr_def :: (String,String,Double,String) -> [Dot_Meta_Attr] +dot_attr_def (ly,fn,fs,sh) = + [("graph:layout",ly) + ,("node:fontname",fn) + ,("node:fontsize",show fs) + ,("node:shape",sh)] + +-- * Graph + +-- | Graph pretty-printer, (v -> [attr],e -> [attr]) +type Graph_Pp v e = ((Int,v) -> [Dot_Attr],((Int,Int),e) -> [Dot_Attr]) + +-- | 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 -> [] + Just f -> [("label",f x)] + in (lift f_v,lift f_e) + +-- | Label 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) -> Graph_Pp v e +gr_pp_label_v f = gr_pp_label_m (Just f) Nothing + +-- | br = brace, csl = comma separated list +br_csl_pp :: Show t => [t] -> String +br_csl_pp l = + case l of + [e] -> show e + _ -> List.bracket ('{','}') (intercalate "," (map show l)) + +-- | Graph type, directed or un-directed. +data Graph_Type = Graph_Digraph | Graph_Ugraph + +g_type_to_string :: Graph_Type -> String +g_type_to_string ty = + case ty of + Graph_Digraph -> "digraph" + Graph_Ugraph -> "graph" + +g_type_to_edge_symbol :: Graph_Type -> String +g_type_to_edge_symbol ty = + case ty of + Graph_Digraph -> " -> " + Graph_Ugraph -> " -- " + +-- | 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 pt = + let r_pp = Show.real_pp_trunc 2 + pt_pp (x,y) = concat [r_pp x,",",r_pp y] + in ("pos",unwords (map pt_pp pt)) + +-- | Variant that accepts single cubic bezier data set. +edge_pos_attr_1 :: Real t => ((t,t),(t,t),(t,t),(t,t)) -> Dot_Attr +edge_pos_attr_1 (p1,p2,p3,p4) = edge_pos_attr [p1,p2,p3,p4] + +{- +-- | Vertex position function. +type POS_FN v = (v -> (Int,Int)) + +g_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 :: 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))),";"] + e_f ((lhs,rhs),lbl) = concat [show lhs,g_type_to_edge_symbol g_typ,show rhs + ,ws (dot_attr_seq_pp (e_attr ((lhs,rhs),lbl))),";"] + in concat [[g_type_to_string g_typ," g {"] + ,map dot_attr_set_pp (dot_attr_collate opt) + ,map v_f v + ,map e_f e + ,["}"]] + +lbl_to_udot :: [Dot_Meta_Attr] -> Graph_Pp v e -> T.Lbl v e -> [String] +lbl_to_udot = lbl_to_dot Graph_Ugraph + +-- | '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] -> 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) + /-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) + +-- | '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") diff --git a/Music/Theory/Graph/Fgl.hs b/Music/Theory/Graph/Fgl.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Fgl.hs @@ -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 + +-- | +-- 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 diff --git a/Music/Theory/Graph/Johnson_2014.hs b/Music/Theory/Graph/Johnson_2014.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Graph/Johnson_2014.hs @@ -0,0 +1,635 @@ +-- | Tom Johnson. /Other Harmony: Beyond Tonal and Atonal/. Editions 75, 2014. +module Music.Theory.Graph.Johnson_2014 where + +import Control.Monad {- base -} +import Data.Int {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Control.Monad.Logic as L {- logict -} +import qualified Data.Map as M {- containers -} +import qualified Data.Graph.Inductive as G {- fgl -} +--import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -} + +import qualified Music.Theory.Combinations as T {- hmt-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.Key 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.Z as T {- hmt -} +import qualified Music.Theory.Z.Forte_1973 as T {- hmt -} +import qualified Music.Theory.Z.Tto as T {- hmt -} +import qualified Music.Theory.Z.Sro as T {- hmt -} + +-- * Common + +type Z12 = Int8 + +dif :: Num a => (a, a) -> a +dif = uncurry (-) + +absdif :: Num a => (a, a) -> a +absdif = abs . dif + +-- | interval (0,11) to interval class (0,6) +i_to_ic :: (Num a, Ord a) => a -> a +i_to_ic n = if n > 6 then 12 - n else n + +p2_and :: (t -> u -> Bool) -> (t -> u -> Bool) -> t -> u -> Bool +p2_and p q i j = p i j && q i j + +-- | degree of intersection +doi :: Eq t => [t] -> [t] -> Int +doi p = length . intersect p + +doi_of :: Eq t => Int -> [t] -> [t] -> Bool +doi_of n p = (==) n . doi p + +-- | The sum of the pointwise absolute difference. +loc_dif :: Num t => [t] -> [t] -> t +loc_dif p q = let f i j = abs (i - j) in sum (zipWith f p q) + +loc_dif_of :: (Eq t, Num t) => t -> [t] -> [t] -> Bool +loc_dif_of n p q = loc_dif p q == n + +loc_dif_in :: (Eq t, Num t) => [t] -> [t] -> [t] -> Bool +loc_dif_in n p q = loc_dif p q `elem` n + +-- | The number of places that are, pointwise, not equal. +-- +-- > loc_dif_n "test" "pest" == 1 +loc_dif_n :: (Eq t,Num i) => [t] -> [t] -> i +loc_dif_n p q = + let f i j = if i == j then 0 else 1 + in sum (zipWith f p q) + +loc_dif_n_of :: Eq t => Int -> [t] -> [t] -> Bool +loc_dif_n_of n p q = loc_dif_n p q == n + +-- > 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 (zipWith (curry absdif) p x) + in minimum (map f (permutations q)) + +min_vl_of :: (Num a, Ord a) => a -> [a] -> [a] -> Bool +min_vl_of n p q = min_vl p q == n + +min_vl_in :: (Num a, Ord a) => [a] -> [a] -> [a] -> Bool +min_vl_in n p q = min_vl p q `elem` n + +combinations2 :: Ord t => [t] -> [(t, t)] +combinations2 p = [(i,j) | i <- p, j <- p, i < j] + +set_pp :: Show t => [t] -> String +set_pp = intercalate "," . map show + +tto_rel_to :: Integral t => T.Z t -> [t] -> [t] -> [T.Tto t] +tto_rel_to z p q = T.z_tto_rel 5 z (T.set p) (T.set q) + +set_pp_tto_rel :: (Integral t, Show t) => T.Z t -> [t] -> [t] -> String +set_pp_tto_rel z p = intercalate "," . map T.tto_pp . tto_rel_to z p + +-- * Map + +m_get :: Ord k => M.Map k v -> k -> v +m_get m i = fromMaybe (error "get") (M.lookup i m) + +-- | degree of intersection +m_doi_of :: M.Map Int [Z12] -> Int -> Int -> Int -> Bool +m_doi_of m n p q = doi_of n (m_get m p) (m_get m q) + +-- * Edge + +-- | Add /k/ as prefix to both left and right hand sides of edge. +e_add_id :: k -> [(t,u)] -> [((k,t),(k,u))] +e_add_id k = map (\(lhs,rhs) -> ((k,lhs),(k,rhs))) + +gen_edges :: (t -> t -> Bool) -> [t] -> [(t,t)] +gen_edges f l = [(p,q) | p <- l, q <- l, f p q] + +gen_u_edges :: Ord a => (a -> a -> Bool) -> [a] -> [(a, a)] +gen_u_edges = T.e_univ_select_u_edges + +-- * Graph + +oh_def_opt :: [T.Dot_Meta_Attr] +oh_def_opt = + [("graph:layout","neato") + ,("graph:epsilon","0.000001") + ,("node:shape","plaintext") + ,("node:fontsize","10") + ,("node:fontname","century schoolbook")] + +gen_graph :: Ord v => [T.Dot_Meta_Attr] -> T.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 opt pp es = T.fgl_to_udot (oh_def_opt ++ opt) (T.gr_pp_label_v pp) (T.g_from_edges es) + +gen_graph_ul_ty :: Ord v => String -> (v -> String) -> [T.Edge v] -> [String] +gen_graph_ul_ty ty = gen_graph_ul [("graph:layout",ty)] + +gen_flt_graph_pp :: Ord t => [T.Dot_Meta_Attr] -> ([t] -> String) -> ([t] -> [t] -> Bool) -> [[t]] -> [String] +gen_flt_graph_pp opt pp f p = gen_graph_ul opt pp (gen_u_edges f p) + +gen_flt_graph :: (Ord t, Show t) => [T.Dot_Meta_Attr] -> ([t] -> [t] -> Bool) -> [[t]] -> [String] +gen_flt_graph opt = gen_flt_graph_pp opt set_pp + +-- * P.12 + +-- > circ_5 12 0 == [0,7,2,9,4,11,6,1,8,3,10,5] +circ_5 :: Integral a => Int -> a -> [a] +circ_5 l n = take l (iterate (T.z_mod T.z12 . (+ 7)) (T.z_mod T.z12 n)) + +all_pairs :: [t] -> [u] -> [(t,u)] +all_pairs x y = [(p,q) | p <- x, q <- y] + +adj :: [t] -> [(t,t)] +adj = T.adj2 1 + +adj_cyc :: [t] -> [(t,t)] +adj_cyc = T.adj2_cyclic 1 + +p12_c5_eset :: [(Int,Int)] +p12_c5_eset = + let l1 = circ_5 4 9 -- [9,4,11,6] + l2 = circ_5 5 10 -- [10,5,0,7,2] + l3 = circ_5 3 1 -- [1,8,3] + align p q = filter ((== 4) . T.z_mod T.z12 . dif) (all_pairs p q) + in concatMap adj [l1,l2,l3] ++ align l1 l2 ++ align l2 l3 + +e_add_label :: (T.Edge v -> l) -> [T.Edge v] -> [T.Edge_Lbl v l] +e_add_label f = let g (p,q) = ((p,q),f (p,q)) in map g + +p12_c5_gr :: [String] +p12_c5_gr = + let o = [("graph:start","187623") + ,("node:fontsize","10") + ,("edge:fontsize","9")] + e_l = e_add_label (i_to_ic . absdif) p12_c5_eset + in gen_graph o (\(_,v) -> [("label",T.pc_pp v)],\(_,e) -> [("label",show e)]) e_l + +-- > T.euler_plane_r p12_euler_plane == [1/1,16/15,9/8,6/5,5/4,4/3,45/32,3/2,8/5,5/3,16/9,15/8] +p12_euler_plane :: T.Euler_Plane Rational +p12_euler_plane = + let f = T.fold_ratio_to_octave_err + l1 = T.tun_seq 4 (3/2) (f (1 * 2/3 * 5/4)) + l2 = T.tun_seq 5 (3/2) (f (1 * 2/3 * 2/3)) + l3 = T.tun_seq 3 (3/2) (f (1 * 2/3 * 4/5)) + (c1,c2) = T.euler_align_rat (5/4,5/4) (l1,l2,l3) + in ([l1,l2,l3],c1 ++ c2) + +p12_euler_plane_gr :: [String] +p12_euler_plane_gr = T.euler_plane_to_dot_rat (0,True) p12_euler_plane + +-- * P.14 + +p14_eset :: ([(Int, Int)], [(Int, Int)], [(Int, Int)]) +p14_eset = + let univ = [0 .. 11] + trs n = map (T.z_mod T.z12 . (+ n)) + e_par = zip univ univ + e_rel = zip univ (trs 9 univ) + e_med = zip univ (trs 4 univ) + in (e_par,e_rel,e_med) + +p14_mk_e :: [(Int, Int)] -> [(T.Key,T.Key)] +p14_mk_e = + let pc_to_key m pc = let (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 + +p14_edges_u :: [(T.Key,T.Key)] +p14_edges_u = + let (e_par,e_rel,e_med) = p14_eset + in p14_mk_e (concat [e_par,e_rel,e_med]) + +p14_edges :: [(T.Key,T.Key)] +p14_edges = + let (e_par,e_rel,e_med) = p14_eset + del_par = [10] + del_rel = [5,6] + del_med = [2,5,8,11] + rem_set r = filter (\(lhs,_) -> lhs `notElem` r) + e_mod = concat [rem_set del_par e_par,rem_set del_rel e_rel,rem_set del_med e_med] + in p14_mk_e e_mod + +p14_mk_gr :: [T.Dot_Meta_Attr] -> [T.Edge T.Key] -> [String] +p14_mk_gr opt e = + let opt' = ("graph:start","168732") : opt + pp = T.gr_pp_label_v T.key_lc_uc_pp + gr = T.g_from_edges e + in T.fgl_to_udot opt' pp gr + +p14_gr_u :: [String] +p14_gr_u = + p14_mk_gr + [("edge:len","1.5") + ,("edge:fontsize","6") + ,("node:shape","box") + ,("node:fontsize","10") + ,("node:fontname","century schoolbook")] + p14_edges_u + +p14_gr :: [String] +p14_gr = p14_mk_gr [] p14_edges + +p14_gen_tonnetz_n :: Int -> [Int] -> [Int] -> [Int] +p14_gen_tonnetz_n n k x = + let gen_neighbours_n l z = map (+ z) l ++ map (z -) l + in if n == 0 + then x + else let r = nub (x ++ concatMap (gen_neighbours_n k) x) + in p14_gen_tonnetz_n (n - 1) k r + +p14_gen_tonnetz_e :: Int -> [Int] -> [Int] -> [((Int, Int), Int)] +p14_gen_tonnetz_e n k = + let gen_e x y = ((min x y,max x y),abs (x - y)) + gen_e_n d_set x y = if abs (x - y) `elem` d_set then Just (gen_e x y) else Nothing + f [p,q] = gen_e_n k p q + f _ = error "p14_gen_tonnetz_e" + in mapMaybe f . T.combinations 2 . p14_gen_tonnetz_n n k + +-- Neo-Riemannian Tonnettz +p14_nrt_gr :: [String] +p14_nrt_gr = + let e = p14_gen_tonnetz_e 3 [7,9,16] [48] + o = [("node:shape","circle") + ,("node:fontsize","10") + ,("node:fontname","century schoolbook") + ,("edge:len","1")] + pp = (\(_,v) -> [("label",T.pc_pp (T.z_mod T.z12 v))],const []) + in gen_graph o pp e + +-- * P.31 + +p31_f_4_22 :: [Z12] +p31_f_4_22 = [0,2,4,7] + +p31_e_set :: [([Z12],[Z12])] +p31_e_set = T.e_univ_select_u_edges (doi_of 3) (map sort (T.z_sro_ti_related T.z12 p31_f_4_22)) + +p31_gr :: [String] +p31_gr = gen_graph_ul [] set_pp p31_e_set + +-- * P.114 + +p114_f_3_7 :: [Z12] +p114_f_3_7 = [0,2,5] + +p114_mk_o :: Show t => t -> [T.Dot_Meta_Attr] +p114_mk_o el = + [("node:shape","box") + ,("edge:len",show el) + ,("edge:fontsize","10")] + +p114_mk_gr :: Double -> ([Z12] -> [Z12] -> Bool) -> [String] +p114_mk_gr el flt = + let n = map sort (T.z_sro_ti_related T.z12 p114_f_3_7) + in gen_flt_graph (p114_mk_o el) flt n + +p114_f37_sc_pp :: [Z12] -> String +p114_f37_sc_pp = set_pp_tto_rel T.z12 [0,2,5] + +p114_g0 :: [String] +p114_g0 = + let mk_e flt = gen_u_edges flt (map sort (T.z_sro_ti_related T.z12 p114_f_3_7)) + in gen_graph_ul (p114_mk_o (2.5::Double)) p114_f37_sc_pp (mk_e (doi_of 2)) + +p114_g1 :: [String] +p114_g1 = p114_mk_gr 2.5 (doi_of 2) + +p114_gr_set :: [(String,[String])] +p114_gr_set = + [("p114.0.dot",p114_g0) + ,("p114.1.dot",p114_g1) + ,("p114.2.dot" + ,let o = [("edge:len","1.25")] + in gen_flt_graph o (loc_dif_of 1) (T.combinations 3 [1::Int .. 6])) + ,("p114.3.dot",p114_mk_gr 1.5 (loc_dif_n_of 1)) + ,("p114.4.dot",p114_mk_gr 1.5 (loc_dif_of 1)) + ,("p114.5.dot",p114_mk_gr 1.5 (loc_dif_of 2)) + ,("p114.6.dot",p114_mk_gr 1.5 (loc_dif_in [1,2])) + ,("p114.7.dot",p114_mk_gr 1.5 (loc_dif_in [1,2,3])) + ,("p114.8.dot",p114_mk_gr 1.5 (min_vl_in [1,2,3])) + ,("p114.9.dot",p114_mk_gr 2.0 (min_vl_in [1,2,3,4])) + ] + +-- * P.125 + +p125_gr :: [String] +p125_gr = + let t :: [[Int]] + 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)) + in gen_graph_ul [] set_pp (T.e_univ_select_u_edges (doi_of 2) ch) + +-- * P.131 + +p131_gr :: [String] +p131_gr = + let c = let u = [6::Int .. 14] + 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 + +p148_mk_gr :: ([Int] -> [Int] -> Bool) -> [String] +p148_mk_gr f = + let mid_set_pp :: [Int] -> String + mid_set_pp = concatMap show . take 3 . drop 1 + i_seq :: Num i => [[i]] + i_seq = permutations [1,2,3,4] + p_seq :: (Ord i,Num i) => [[i]] + p_seq = sort (map (T.dx_d 0) i_seq) + in gen_graph_ul [("edge:len","1.75")] mid_set_pp (T.e_univ_select_u_edges f p_seq) + +p148_gr_set :: [(String,[String])] +p148_gr_set = + [("p148.0.dot",p148_mk_gr (doi_of 4)) + ,("p148.1.dot",p148_mk_gr (min_vl_in [1])) + ,("p148.2.dot",p148_mk_gr (min_vl_in [1,2])) + ,("p148.3.dot",p148_mk_gr (p2_and (doi_of 4) (min_vl_in [1]))) + ,("p148.4.dot",p148_mk_gr (p2_and (doi_of 4) (min_vl_in [1,2]))) + ,("p148.5.dot",p148_mk_gr (loc_dif_n_of 1)) + ,("p148.6.dot",p148_mk_gr (loc_dif_of 1)) + ] + +-- * P.162 + +-- > length p162_ch == 30 +p162_ch :: [[Int]] +p162_ch = + let n = [0::Int,1,2,3,4,5,6,7,8] + c = T.combinations 4 n + in filter ((== 1) . (`mod` 4) . sum) c + +-- > length p162_e == 47 +p162_e :: [T.Edge [Int]] +p162_e = T.e_univ_select_u_edges (doi_of 3) p162_ch + +p162_gr :: [String] +p162_gr = + let opt = [("graph:layout","neato") + ,("edge:len","1.75")] + in gen_graph_ul opt set_pp p162_e + +-- * P.172 + +-- > M.size p172_nd_map == 24 +p172_nd_map :: M.Map Int [Z12] +p172_nd_map = + let nd_exp = map sort (T.z_sro_ti_related T.z12 [0,1,3,7]) + in M.fromList (zip [0..] nd_exp) + +p172_nd_e_set :: [(Int,Int)] +p172_nd_e_set = T.e_univ_select_u_edges (m_doi_of p172_nd_map 0) [0..23] + +p172_nd_e_set_alt :: [T.Edge Int] +p172_nd_e_set_alt = concatMap (T.e_path_to_edges . T.close 1) p172_cyc0 + +p172_gr :: G.Gr () () +p172_gr = G.mkUGraph [0..23] p172_nd_e_set + +p172_set_pp :: Int -> String +p172_set_pp = set_pp . m_get p172_nd_map + +-- > let (c0,c1) = p172_all_cyc p172_gr +-- > (length c0,length c1) == (48,48) +p172_all_cyc :: ([[Int]], [[Int]]) +p172_all_cyc = + let (a, b) = T.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)) + +p172_cyc0 :: [[Int]] +p172_cyc0 = map (!! 0) [fst p172_all_cyc,snd p172_all_cyc] + +p172_g1 :: [String] +p172_g1 = gen_graph_ul [("edge:len","2.0")] p172_set_pp p172_nd_e_set + +p172_g2 :: [String] +p172_g2 = gen_graph_ul [] p172_set_pp p172_nd_e_set_alt + +p172_g3 :: [String] +p172_g3 = + let m_set_pp_tto_rel = set_pp_tto_rel T.z12 [0,1,3,7] . m_get p172_nd_map + in gen_graph_ul [("node:shape","box"),("edge:len","2.0")] m_set_pp_tto_rel p172_nd_e_set + +-- | 'T.Tto' T/n/. +tto_tn :: Integral t => t -> T.Tto t +tto_tn n = T.Tto (T.z_mod T.z12 n) 1 False + +-- | 'Z.Tto' T/n/I. +tto_tni :: Integral t => t -> T.Tto t +tto_tni n = T.Tto (T.z_mod T.z12 n) 1 True + +gen_tto_alt_seq :: Integral t => (t -> T.Tto t,t -> T.Tto t) -> Int -> t -> t -> t -> [T.Tto t] +gen_tto_alt_seq (f,g) k n m x = + let t = map f (take k [x,x + n ..]) + i = map g (take k [x + m,x + m + n ..]) + in T.interleave t i + +-- | /k/ is length of the T & I sequences, /n/ is the T & I sequence +-- interval, /m/ is the interval between the T & I sequence. +-- +-- > r = ["T0 T5I T3 T8I T6 T11I T9 T2I","T1 T6I T4 T9I T7 T0I T10 T3I"] +-- > map (unwords . map T.tto_pp . gen_tni_seq 4 3 5) [0,1] == r +gen_tni_seq :: Integral t => Int -> t -> t -> t -> [T.Tto t] +gen_tni_seq = gen_tto_alt_seq (tto_tn,tto_tni) + +-- > putStrLn $ unlines $ map (unwords . map Z.tto_pp) c4 +p172_c4 :: [[T.Tto Int]] +p172_c4 = map (gen_tni_seq 3 4 9) [0 .. 3] ++ map (gen_tni_seq 2 6 11) [0 .. 5] + +tto_seq_edges :: (Show t,Num t,Eq t) => [[T.Tto t]] -> [(String, String)] +tto_seq_edges = nub . sort . concatMap (map T.t2_sort . adj_cyc . map T.tto_pp) + +p172_g4 :: [String] +p172_g4 = gen_graph_ul [("edge:len","2.0")] id (tto_seq_edges p172_c4) + +p172_gr_set :: [(String,[String])] +p172_gr_set = + [("p172.0.dot",p172_g1) + ,("p172.1.dot",p172_g2) + ,("p172.2.dot",p172_g3) + ,("p172.3.dot",p172_g4)] + +-- * P.177 + +-- > map (partition_ic 4) p_set +-- > map (partition_ic 6) p_set +partition_ic :: (Num t, Ord t, Show t) => t -> [t] -> ([t], [t]) +partition_ic n p = + case find ((== n) . i_to_ic . absdif) (combinations2 p) of + Just (i,j) -> let q = sort [i,j] in (q,sort (p \\ q)) + Nothing -> error (show ("partition_ic",n,p)) + +p177_gr_set :: [(String,[String])] +p177_gr_set = + let p_set = concatMap (T.z_sro_ti_related T.z12) [[0::Int,1,4,6],[0,1,3,7]] + in [("p177.0.dot",gen_graph_ul [] set_pp (map (partition_ic 4) p_set)) + ,("p177.1.dot",gen_graph_ul_ty "circo" set_pp (map (partition_ic 6) p_set)) + ,("p177.2.dot" + ,let gr_pp = T.gr_pp_label_v set_pp + gr = T.g_from_edges (map (partition_ic 6) p_set) + in T.fgl_to_udot [("edge:len","1.5")] gr_pp gr)] + +-- * P.178 + +type SC = [Int] +type PCSET = [Int] + +ait :: [SC] +ait = map T.sc ["4-Z15","4-Z29"] + +-- | List of pcsets /s/ where /prime(p+s)=r/ and /prime(q+s)=r/. +-- /#p/ and /#q/ must be equal, and less than /#r/. +-- +-- > mk_bridge (T.sc "4-Z15") [0,6] [1,7] == [[2,5],[8,11]] +-- > mk_bridge (T.sc "4-Z29") [0,6] [1,7] == [[2,11],[5,8]] +mk_bridge :: SC -> PCSET -> PCSET -> [PCSET] +mk_bridge r p q = + let n = length r - length p + c = T.combinations n [0..11] + f s = T.z_forte_prime T.z12 (p ++ s) == r && T.z_forte_prime T.z12 (q ++ s) == r + in filter f c + +-- | 'concatMap' of 'mk_bridge'. +-- +-- > mk_bridge_set ait [0,6] [1,7] == [[2,5],[8,11],[2,11],[5,8]] +mk_bridge_set :: [SC] -> PCSET -> PCSET -> [PCSET] +mk_bridge_set r_set p q = concatMap (\r -> mk_bridge r p q) r_set + +mk_bridge_set_seq :: [SC] -> [PCSET] -> [[PCSET]] +mk_bridge_set_seq r_set k_seq = + case k_seq of + p:q:k_seq' -> mk_bridge_set r_set p q : mk_bridge_set_seq r_set (q : k_seq') + _ -> [] + +-- > zip [0..] (mk_bridge_set_seq ait p178_i6_seq) +p178_i6_seq :: [PCSET] +p178_i6_seq = map (sort . (\n -> T.z_pcset T.z12 [n,n+6])) [0..6] + +p178_ch :: [(PCSET,[PCSET],PCSET)] +p178_ch = zip3 p178_i6_seq (mk_bridge_set_seq ait p178_i6_seq) (tail p178_i6_seq) + +type ID = Char + +-- | Add 'ID' to vertices, the @2,11@ the is between @0,6@ and @1,7@ +-- is /not/ the same @2,11@ that is between @3,9@ and @4,10@. +p178_e :: [((ID,PCSET),(ID,PCSET))] +p178_e = + let f k (p,c,q) = map (\x -> (('.',p),(k,x))) c ++ map (\x -> ((k,x),('.',q))) c + in concat (zipWith f ['a'..] p178_ch) + +p178_gr_1 :: [String] +p178_gr_1 = + let opt = [("node:shape","rectangle") + ,("node:start","1362874") + ,("edge:len","2")] + in gen_graph_ul opt (set_pp . snd) p178_e + +p178_gr_2 :: [String] +p178_gr_2 = + let opt = [("node:shape","point")] + in gen_graph_ul opt (const "") p178_e + +-- * P.196 + +p196_gr :: [String] +p196_gr = gen_flt_graph [("edge:len","1.25")] (loc_dif_of 1) (T.combinations 3 [1::Int .. 6]) + +-- * P.201 + +type SET = [Int] +type E = (SET,SET) + +bd_9_3_2_12 :: [SET] +bd_9_3_2_12 = + [[0,1,2],[0,1,2],[0,3,4],[0,3,4],[0,5,6],[0,5,7],[0,6,8],[0,7,8] + ,[1,3,5],[1,3,8],[1,4,5],[1,4,8],[1,6,7],[1,6,7] + ,[2,3,6],[2,3,7],[2,4,6],[2,4,7],[2,5,8],[2,5,8] + ,[3,5,6],[3,7,8] + ,[4,5,7],[4,6,8]] + +p201_mk_e :: [Int] -> [E] +p201_mk_e = + let f n s = if n `elem` s then Just ([n],sort (n `delete` s)) else Nothing + g n = mapMaybe (f n) bd_9_3_2_12 + in concatMap g + +p201_e :: [[E]] +p201_e = map p201_mk_e [[0,3,4],[1,6,7],[2,5,8]] + +p201_o :: [T.Dot_Meta_Attr] +p201_o = + [("graph:splines","false") + ,("node:shape","box") + ,("edge:len","1.75")] + +-- > length p201_gr_set +p201_gr_set :: [[String]] +p201_gr_set = map (gen_graph_ul p201_o set_pp) p201_e + +p201_gr_join :: [String] +p201_gr_join = + let e = zipWith e_add_id [0::Int ..] p201_e + in gen_graph_ul p201_o (set_pp . snd) (concat e) + +-- * P.205 + +bd_9_3_2_34 :: [SET] +bd_9_3_2_34 = + [[0,1,2],[0,1,3],[0,2,4],[0,3,4] + ,[0,5,6],[0,5,7],[0,6,8],[0,7,8] + ,[1,2,5],[1,3,6],[1,4,5],[1,4,8] + ,[1,6,7],[1,7,8],[2,3,6],[2,3,7] + ,[2,4,7],[2,5,8],[2,6,8],[3,4,8] + ,[3,5,7],[3,5,8],[4,5,6],[4,6,7]] + +p205_mk_e :: [Int] -> [E] +p205_mk_e = + let f n s = if n `elem` s then Just ([n],sort (n `delete` s)) else Nothing + g n = mapMaybe (f n) bd_9_3_2_34 + in concatMap g + +p205_gr :: [String] +p205_gr = + let o = [("graph:splines","false"),("node:shape","box"),("edge:len","2.25")] + in gen_graph_ul o set_pp (p205_mk_e [0..8]) + +-- * IO + +-- > wr_graphs "/home/rohan/sw/hmt/data/dot/tj/oh/" +wr_graphs :: FilePath -> IO () +wr_graphs dir = do + let f (nm,gr) = writeFile (dir ++ "tj_oh_" ++ nm) (unlines gr) + f ("p012.1.dot",p12_c5_gr) + f ("p012.2.dot",p12_euler_plane_gr) + f ("p014.1.dot",p14_gr_u) + f ("p014.2.dot",p14_gr) + f ("p014.3.dot",p14_nrt_gr) + f ("p031.dot",p31_gr) + mapM_ f p114_gr_set + f ("p125.dot",p125_gr) + f ("p131.dot",p131_gr) + mapM_ f p148_gr_set + f ("p162.dot",p162_gr) + mapM_ f p172_gr_set + mapM_ f p177_gr_set + f ("p178.1.dot",p178_gr_1) + f ("p178.2.dot",p178_gr_2) + f ("p196.dot",p196_gr) + mapM_ f (zip ["p201.1.dot","p201.2.dot","p201.3.dot"] p201_gr_set) + f ("p201.4.dot",p201_gr_join) + f ("p205.dot",p205_gr) diff --git a/Music/Theory/Instrument/Choir.hs b/Music/Theory/Instrument/Choir.hs --- a/Music/Theory/Instrument/Choir.hs +++ b/Music/Theory/Instrument/Choir.hs @@ -1,9 +1,9 @@ module Music.Theory.Instrument.Choir where import Data.List.Split {- split -} -import Data.Maybe {- base -} import qualified Music.Theory.Clef as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Pitch as T {- hmt -} import qualified Music.Theory.Pitch.Name as T {- hmt -} @@ -43,13 +43,9 @@ ,(Alto,(T.g3,T.c5)) ,(Soprano,(T.c4,T.f5))] --- | Erroring variant. -lookup_err :: Eq a => a -> [(a,b)] -> b -lookup_err e = fromMaybe (error "lookup_err") . lookup e - -- | Lookup voice range table. voice_rng :: Voice_Rng_Tbl -> Voice -> (T.Pitch,T.Pitch) -voice_rng tbl v = lookup_err v tbl +voice_rng tbl v = T.lookup_err v tbl -- | Lookup 'voice_rng_tbl_std'. voice_rng_std :: Voice -> (T.Pitch,T.Pitch) diff --git a/Music/Theory/Instrument/Names.hs b/Music/Theory/Instrument/Names.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Instrument/Names.hs @@ -0,0 +1,114 @@ +module Music.Theory.Instrument.Names where + +import Data.List.Split {- split -} + +-- | (family,abbreviations,names,transpositions) +instrument_db' :: [(String,String,String,String)] +instrument_db' = + [("br","b.tbn","bass trombone","") + ,("br","b.tuba","bass tuba","") + ,("br","euph","euphonium","") + ,("br","hn","french horn","F") + ,("br","tbn;trm","trombone","") + ,("br","tb;tba","tuba","") + ,("br","tpt","trumpet","B♭") + ,("br","t.tbn","tenor trombone","") + ,("br","crt","cornet","") + ,("br","fgh;flhn","flugel horn","") + ,("br","p.tpt","piccolo trumpet","") + ,("el","cd","compact disc","") + ,("el","el;elec","electronics","") + ,("el","tp","tape","") + ,("el","om","ondes martenot","") + ,("kb","h;hrm","harmonium","") + ,("kb","e.pf","electric piano","") + ,("kb","p;pf;pno","piano;pianoforte","") + ,("kb","o;or;org","organ","") + ,("kb","kb;kbd","keyboard","") + ,("kb","cel","celeste","") + ,("kb","clvd","clavichord","") + ,("kb","hpd;hpcd","harpsichord","") + ,("kb","syn","synthesiser","") + ,("pc","bd","bass drum","") + ,("pc","btl","bottle","") + ,("pc","cast","castanets","") + ,("pc","cbell","cow-bell","") + ,("pc","bell","bell","chimes") + ,("pc","clv","clave","") + ,("pc","crot","crotales","") + ,("pc","cym","cymbals","") + ,("pc","dm","drum","") + ,("pc","gl;glsp","glockenspiel","") + ,("pc","mcas","maracas","") + ,("pc","met.bl","metal block","") + ,("pc","mr;mar","marimba","") + ,("pc","sd","side drum","") + ,("pc","sn.dm","snare drum","") + ,("pc","sus.cym","suspended cymbal","") + ,("pc","tamb","tambourine","") + ,("pc","tam","tam tam","") + ,("pc","t.bells","tubular bells","") + ,("pc","td","tenor drum","") + ,("pc","tri;tgl","triangle","") + ,("pc","tm;timp","timpani","") + ,("pc","tpl.bl","temple blocks","") + ,("pc","vb;vib","vibraphone","") + ,("pc","wdbl","wood block","") + ,("pc","xyl","xylophone","") + ,("str","va;vla","viola","") + ,("str","vc;vlc","cello;violoncello","") + ,("str","vn;vln","violin","") + ,("str","cb","contrabass","") + ,("str","db","double bass","") + ,("str","vda","viola d'amore","") + ,("str","b.gtr","bass guitar","") + ,("str","e.gtr","electric guitar","") + ,("str","gtr","guitar","") + ,("str","","lute","") + ,("str","zith","zither","") + ,("str","hp","harp","") + ,("str","dulc","dulcimer","") + ,("str","mand","mandolin","") + ,("vc","a;alt","alto","") + ,("vc","b;bass","bass","") + ,("vc","mz;mez","mezzo-soprano","") + ,("vc","n;nar","narrator","") + ,("vc","s;sop","soprano","") + ,("vc","t;tn","tenor","") + ,("vc","v;vc;voc","voice","") + ,("vc","ch","chorus","") + ,("vc","ctral","contralto","") + ,("vc","ctrbs","contrabass","") + ,("vc","bar","baritone","") + ,("vc","b.bar","bass baritone","") + ,("ww","b.cl","bass clarinet","") + ,("ww","cb.cl","contrabass clarinet","") + ,("ww","c;cl","clarinet","B♭") + ,("ww","a.fl","alto flute","G") + ,("ww","b.fl","bass flute","C") + ,("ww","bn;bsn","bassoon","") + ,("ww","f;fl","flute","") + ,("ww","hb;htb","hautbois","") + ,("ww","o;ob","oboe","") + ,("ww","p;picc","piccolo","") + ,("ww","ca","cor anglais","") + ,("ww","c.bn","contrabassoon","") + ,("ww","a.sax","alto saxophone","E♭") + ,("ww","b.sax","baritone saxophone","E♭") + ,("ww","b.ob","bass oboe","") + ,("ww","cfg","contrafagotto","") + ,("ww","eh;en.hn","english horn","") + ,("ww","fg","fagotto","") + ,("ww","rec","recorder","") + ,("ww","sax","saxophone","") + ,("ww","s.sax","soprano saxophone","B♭") + ,("ww","t.sax","tenor saxophone","B♭") + ,("ww","oca","ocarina","") + ] + +-- | (family,[abbreviations],[names],[transpositions]) +instrument_db :: [(String,[String],[String],[String])] +instrument_db = + let sep = splitOn ";" + f (fm,ab,nm,tr) = (fm,sep ab,sep nm,sep tr) + in map f instrument_db' diff --git a/Music/Theory/Interval.hs b/Music/Theory/Interval.hs --- a/Music/Theory/Interval.hs +++ b/Music/Theory/Interval.hs @@ -4,16 +4,17 @@ import Data.List {- base -} import Data.Maybe {- base -} -import Music.Theory.Pitch -import Music.Theory.Pitch.Note +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) @@ -21,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 :: Octave} + ,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 :: Note_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) @@ -65,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 @@ -95,65 +96,39 @@ in if dir == GT then negate n - o else n + o Nothing -> error "interval_semitones" --- | Inclusive set of 'Note_T' 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 n1 n2 = - let fn x = toEnum (x `mod` 7) - n1' = fromEnum n1 - n2' = fromEnum n2 - n2'' = if n1' > n2' then n2' + 7 else n2' - in map fn [n1' .. n2''] - --- | Invert 'Ordering', ie. 'GT' becomes 'LT' and vice versa. --- --- > map invert_ordering [LT,EQ,GT] == [GT,EQ,LT] -invert_ordering :: Ordering -> Ordering -invert_ordering x = - case x of - LT -> GT - EQ -> EQ - GT -> LT - -- | 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 :: Pitch -> Pitch -> Interval +-- > 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 - (Pitch n1 _ o1) = p1 - (Pitch n2 _ o2) = p2 - p1' = pitch_to_pc p1 - p2' = pitch_to_pc p2 + (T.Pitch n1 _ o1) = p1 + (T.Pitch n2 _ o2) = p2 + p1' = T.pitch_to_pc p1 + 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 } _ -> Interval ty qu c (o2 - o1 + o_a) --- | Apply 'invert_ordering' to 'interval_direction' of 'Interval'. +-- | Apply 'T.ord_invert' to 'interval_direction' of 'Interval'. -- -- > invert_interval (Interval Third Major LT 1) == Interval Third Major GT 1 invert_interval :: Interval -> Interval -invert_interval (Interval t qu d o) = - let d' = invert_ordering d - in Interval t qu d' o +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 @@ -177,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) @@ -185,9 +160,9 @@ -- | Transpose a 'Pitch' by an 'Interval'. -- -- > transpose (Interval Third Diminished LT 0) (Pitch C Sharp 4) == Pitch E Flat 4 -pitch_transpose :: Interval -> Pitch -> Pitch +pitch_transpose :: Interval -> T.Pitch -> T.Pitch pitch_transpose i ip = - let (Pitch p_n p_a p_o) = ip + let (T.Pitch p_n p_a p_o) = ip (Interval i_t i_q i_d i_o) = i i_d' = if i_d == GT then -1 @@ -199,10 +174,10 @@ else if p_n' < p_n && i_d == LT then 1 else 0 - ip' = Pitch p_n' p_a (p_o + i_o + oa) + ip' = T.Pitch p_n' p_a (p_o + i_o + oa) st = if i_d == GT - then (pitch_to_pc ip - pitch_to_pc ip') `mod` 12 - else (pitch_to_pc ip' - pitch_to_pc ip) `mod` 12 + then (T.pitch_to_pc ip - T.pitch_to_pc ip') `mod` 12 + else (T.pitch_to_pc ip' - T.pitch_to_pc ip) `mod` 12 ty = if i_d == GT then interval_ty p_n' p_n else interval_ty p_n p_n' @@ -210,14 +185,14 @@ in fromMaybe err (interval_q ty (fromIntegral st)) qd = quality_difference qu i_q * i_d' p_a' = toEnum (fromEnum p_a + (qd * 2)) - in ip' { alteration = p_a' } + in ip' {T.alteration = p_a'} -- | Make leftwards (perfect fourth) and and rightwards (perfect -- fifth) circles from 'Pitch'. -- -- > let c = circle_of_fifths (Pitch F Sharp 4) -- > in map pitch_to_pc (snd c) == [6,1,8,3,10,5,12,7,2,9,4,11] -circle_of_fifths :: Pitch -> ([Pitch], [Pitch]) +circle_of_fifths :: T.Pitch -> ([T.Pitch], [T.Pitch]) circle_of_fifths x = let p4 = Interval Fourth Perfect LT 0 p5 = Interval Fifth Perfect LT 0 @@ -228,7 +203,7 @@ -- displacement. -- -- > mapMaybe parse_interval_type (map show [1 .. 15]) -parse_interval_type :: String -> Maybe (Interval_T,Octave) +parse_interval_type :: String -> Maybe (Interval_Type,T.Octave) parse_interval_type n = case reads n of [(n',[])] -> if n' == 0 @@ -240,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) @@ -249,11 +224,11 @@ -- 'parse_interval_type'. -- -- > map interval_type_degree [(Third,0),(Second,1),(Unison,2)] == [3,9,15] -interval_type_degree :: (Interval_T,Octave) -> Int +interval_type_degree :: (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. @@ -282,6 +257,10 @@ '+':q:n -> f q n q:n -> f q n _ -> Nothing + +-- | 'error' variant. +parse_interval_err :: String -> Interval +parse_interval_err = fromMaybe (error "parse_interval") . parse_interval -- | Pretty printer for intervals, inverse of 'parse_interval'. interval_pp :: Interval -> String diff --git a/Music/Theory/Interval/Barlow_1987.hs b/Music/Theory/Interval/Barlow_1987.hs --- a/Music/Theory/Interval/Barlow_1987.hs +++ b/Music/Theory/Interval/Barlow_1987.hs @@ -4,12 +4,12 @@ module Music.Theory.Interval.Barlow_1987 where import Data.List {- base -} -import Data.Maybe {- base -} -import Data.Numbers.Primes {- primes -} import Data.Ratio {- base -} import Text.Printf {- base -} -import Music.Theory.Tuning +import qualified Music.Theory.Math as T {- hmt -} +import qualified Music.Theory.Math.Prime as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} -- | Barlow's /indigestibility/ function for prime numbers. -- @@ -20,157 +20,93 @@ square n = n * n in 2 * (square (p' - 1) / p') --- | Generate list of factors of /n/ from /x/. --- --- > factor primes 315 == [3,3,5,7] -factor :: Integral a => [a] -> a -> [a] -factor x n = - case x of - [] -> undefined - i:x' -> if i * i > n - then [n] - else if rem n i == 0 - then i : factor x (quot n i) - else factor x' n - --- | 'factor' /n/ from 'primes'. --- --- > prime_factors 315 == [3,3,5,7] -prime_factors :: Integral a => a -> [a] -prime_factors = factor primes - --- | Collect number of occurences of each element of a sorted list. --- --- > multiplicities [1,1,1,2,2,3] == [(1,3),(2,2),(3,1)] -multiplicities :: (Eq a,Integral n) => [a] -> [(a,n)] -multiplicities = - let f x = case x of - [] -> undefined - e:_ -> (e,genericLength x) - in map f . group - --- | 'multiplicities' '.' 'prime_factors'. --- --- > prime_factors_m 315 == [(3,2),(5,1),(7,1)] -prime_factors_m :: Integral a => a -> [(a,a)] -prime_factors_m = multiplicities . prime_factors - --- | Merging function for 'rational_prime_factors_m'. -merge :: (Ord a,Num b,Eq b) => [(a,b)] -> [(a,b)] -> [(a,b)] -merge p q = - case (p,q) of - (_,[]) -> p - ([],_) -> map (\(i,j) -> (i,-j)) q - ((a,b):p',(c,d):q') -> - if a < c - then (a,b) : merge p' q - else if a > c - then (c,-d) : merge p q' - else if b /= d - then (a,b-d) : merge p' q' - else merge p' q' - --- | Collect the prime factors in a rational number given as a --- numerator/ denominator pair (n,m). Prime factors are listed in --- ascending order with their positive or negative multiplicities, --- depending on whether the prime factor occurs in the numerator or --- the denominator (after cancelling out common factors). --- --- > rational_prime_factors_m (16,15) == [(2,4),(3,-1),(5,-1)] --- > rational_prime_factors_m (10,9) == [(2,1),(3,-2),(5,1)] --- > rational_prime_factors_m (81,64) == [(2,-6),(3,4)] --- > rational_prime_factors_m (27,16) == [(2,-4),(3,3)] --- > rational_prime_factors_m (12,7) == [(2,2),(3,1),(7,-1)] -rational_prime_factors_m :: Integral b => (b,b) -> [(b,b)] -rational_prime_factors_m (n,m) = - let n' = prime_factors_m n - m' = prime_factors_m m - in merge n' m' - --- | Variant of 'rational_prime_factors_m' giving results in a table --- up to the /n/th prime. --- --- > rational_prime_factors_t 6 (12,7) == [2,1,0,-1,0,0] -rational_prime_factors_t :: Integral b => Int -> (b,b) -> [b] -rational_prime_factors_t n x = - let r = rational_prime_factors_m x - in map (\i -> fromMaybe 0 (lookup i r)) (take n primes) - -- | Compute the disharmonicity of the interval /(p,q)/ using the -- prime valuation function /pv/. -- --- > map (disharmonicity barlow) [(9,10),(8,9)] ~= [12.733333,8.333333] +-- > map (disharmonicity barlow) [(9,10),(8,9)] == ([12 + 11/15,8 + 1/3] :: [Rational]) disharmonicity :: (Integral a,Num b) => (a -> b) -> (a,a) -> b disharmonicity pv (p,q) = - let n = rational_prime_factors_m (p,q) + let n = T.rat_prime_factors_m (p,q) in sum [abs (fromIntegral j) * pv i | (i,j) <- n] -- | The reciprocal of 'disharmonicity'. -- --- > map (harmonicity barlow) [(9,10),(8,9)] ~= [0.078534,0.120000] +-- > map (harmonicity barlow) [(9,10),(8,9),(2,1)] == ([15/191,3/25,1] :: [Rational]) harmonicity :: (Integral a,Fractional b) => (a -> b) -> (a,a) -> b harmonicity pv = recip . disharmonicity pv +harmonicity_m :: (Eq b,Integral a,Fractional b) => (a -> b) -> (a,a) -> Maybe b +harmonicity_m pv = T.recip_m . disharmonicity pv + -- | Variant of 'harmonicity' with 'Ratio' input. +-- +-- > harmonicity_r barlow 1 == 1/0 harmonicity_r :: (Integral a,Fractional b) => (a -> b) -> Ratio a -> b -harmonicity_r pv = harmonicity pv . from_rational - --- | 'uncurry' ('%'). -to_rational :: Integral a => (a,a) -> Ratio a -to_rational = uncurry (%) +harmonicity_r pv = harmonicity pv . T.rational_nd --- | Make 'numerator' 'denominator' pair of /n/. -from_rational :: Integral t => Ratio t -> (t, t) -from_rational n = (numerator n,denominator n) +-- | Variant of 'harmonicity_r' with output in (0,100), infinity maps to 100. +harmonicity_r_100 :: (RealFrac b, Integral a) => (a -> b) -> Ratio a -> Int +harmonicity_r_100 pv x = + case harmonicity_m pv (T.rational_nd x) of + Nothing -> 100 + Just y -> round (y * 100) -- | Set of 1. interval size (cents), 2. intervals as product of -- powers of primes, 3. frequency ratio and 4. harmonicity value. -type Table_2_Row = (Double,[Integer],Rational,Double) +type Table_2_Row = (Double,[Int],Rational,Double) +-- | Given ratio /r/ generate 'Table_2_Row' +mk_table_2_row :: Rational -> Table_2_Row +mk_table_2_row r = + (T.fratio_to_cents r + ,T.rat_prime_factors_t 6 (T.rational_nd r) + ,r + ,harmonicity_r barlow r) + -- | Table 2 (p.45) -- -- > length (table_2 0.06) == 24 +-- > length (table_2 0.04) == 66 table_2 :: Double -> [Table_2_Row] table_2 z = let g n = n <= 2 && n >= 1 r = nub (sort (filter g [p % q | p <- [1..81],q <- [1..81]])) - h = map (harmonicity_r barlow) r - f = (> z) . snd - k (i,j) = (fratio_to_cents i,rational_prime_factors_t 6 (from_rational i),i,j) - in map k (filter f (zip r h)) + f (_,_,_,h) = h > z + in filter f (map mk_table_2_row r) --- | Pretty printer for 'Table_2_Row' values. --- --- > mapM_ (putStrLn . table_2_pp) (table_2 0.06) --- --- > 0.000 | 0 0 0 0 0 0 | 1:1 | Infinity --- > 111.731 | 4 -1 -1 0 0 0 | 15:16 | 0.076531 --- > 182.404 | 1 -2 1 0 0 0 | 9:10 | 0.078534 --- > 203.910 | -3 2 0 0 0 0 | 8:9 | 0.120000 --- > 231.174 | 3 0 0 -1 0 0 | 7:8 | 0.075269 --- > 266.871 | -1 -1 0 1 0 0 | 6:7 | 0.071672 --- > 294.135 | 5 -3 0 0 0 0 | 27:32 | 0.076923 --- > 315.641 | 1 1 -1 0 0 0 | 5:6 | 0.099338 --- > 386.314 | -2 0 1 0 0 0 | 4:5 | 0.119048 --- > 407.820 | -6 4 0 0 0 0 | 64:81 | 0.060000 --- > 435.084 | 0 2 0 -1 0 0 | 7:9 | 0.064024 --- > 498.045 | 2 -1 0 0 0 0 | 3:4 | 0.214286 --- > 519.551 | -2 3 -1 0 0 0 | 20:27 | 0.060976 --- > 701.955 | -1 1 0 0 0 0 | 2:3 | 0.272727 --- > 764.916 | 1 -2 0 1 0 0 | 9:14 | 0.060172 --- > 813.686 | 3 0 -1 0 0 0 | 5:8 | 0.106383 --- > 884.359 | 0 -1 1 0 0 0 | 3:5 | 0.110294 --- > 905.865 | -4 3 0 0 0 0 | 16:27 | 0.083333 --- > 933.129 | 2 1 0 -1 0 0 | 7:12 | 0.066879 --- > 968.826 | -2 0 0 1 0 0 | 4:7 | 0.081395 --- > 996.090 | 4 -2 0 0 0 0 | 9:16 | 0.107143 --- > 1017.596 | 0 2 -1 0 0 0 | 5:9 | 0.085227 --- > 1088.269 | -3 1 1 0 0 0 | 8:15 | 0.082873 --- > 1200.000 | 1 0 0 0 0 0 | 1:2 | 1.000000 +{- | Pretty printer for 'Table_2_Row' values. + +> mapM_ (putStrLn . table_2_pp) (table_2 0.06) + +> > 0.000 | 0 0 0 0 0 0 | 1:1 | Infinity +> > 111.731 | 4 -1 -1 0 0 0 | 15:16 | 0.076531 +> > 182.404 | 1 -2 1 0 0 0 | 9:10 | 0.078534 +> > 203.910 | -3 2 0 0 0 0 | 8:9 | 0.120000 +> > 231.174 | 3 0 0 -1 0 0 | 7:8 | 0.075269 +> > 266.871 | -1 -1 0 1 0 0 | 6:7 | 0.071672 +> > 294.135 | 5 -3 0 0 0 0 | 27:32 | 0.076923 +> > 315.641 | 1 1 -1 0 0 0 | 5:6 | 0.099338 +> > 386.314 | -2 0 1 0 0 0 | 4:5 | 0.119048 +> > 407.820 | -6 4 0 0 0 0 | 64:81 | 0.060000 +> > 435.084 | 0 2 0 -1 0 0 | 7:9 | 0.064024 +> > 498.045 | 2 -1 0 0 0 0 | 3:4 | 0.214286 +> > 519.551 | -2 3 -1 0 0 0 | 20:27 | 0.060976 +> > 701.955 | -1 1 0 0 0 0 | 2:3 | 0.272727 +> > 764.916 | 1 -2 0 1 0 0 | 9:14 | 0.060172 +> > 813.686 | 3 0 -1 0 0 0 | 5:8 | 0.106383 +> > 884.359 | 0 -1 1 0 0 0 | 3:5 | 0.110294 +> > 905.865 | -4 3 0 0 0 0 | 16:27 | 0.083333 +> > 933.129 | 2 1 0 -1 0 0 | 7:12 | 0.066879 +> > 968.826 | -2 0 0 1 0 0 | 4:7 | 0.081395 +> > 996.090 | 4 -2 0 0 0 0 | 9:16 | 0.107143 +> > 1017.596 | 0 2 -1 0 0 0 | 5:9 | 0.085227 +> > 1088.269 | -3 1 1 0 0 0 | 8:15 | 0.082873 +> > 1200.000 | 1 0 0 0 0 0 | 1:2 | 1.000000 +-} table_2_pp :: Table_2_Row -> String table_2_pp (i,j,k,l) = let i' = printf "%8.3f" i j' = unwords (map (printf "%2d") j) - k' = let (p,q) = from_rational k in printf "%2d:%-2d" q p + k' = let (p,q) = T.rational_nd k in printf "%2d:%-2d" q p l' = printf "%1.6f" l in intercalate " | " [i',j',k',l'] diff --git a/Music/Theory/Key.hs b/Music/Theory/Key.hs --- a/Music/Theory/Key.hs +++ b/Music/Theory/Key.hs @@ -1,33 +1,203 @@ -- | Common music keys. module Music.Theory.Key where +import Control.Monad {- base -} +import Data.Char {- base -} import Data.List {- base -} +import Data.Maybe {- base -} -import Music.Theory.Pitch -import Music.Theory.Pitch.Name -import Music.Theory.Pitch.Note -import Music.Theory.Interval +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.Pitch.Note as T +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) --- | A common music notation key is a 'Note_T', 'Alteration_T', --- 'Mode_T' triple. -type Key = (Note_T,Alteration_T,Mode_T) +-- | 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 -> String +mode_identifier_pp = map toLower . mode_pp + +-- | There are two modes, given one return the other. +mode_parallel :: Mode -> Mode +mode_parallel m = if m == Minor_Mode then Major_Mode else Minor_Mode + +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', 'Alteration', 'Mode' triple. +type Key = (T.Note,T.Alteration,Mode) + +-- | 'Mode' of 'Key'. +key_mode :: Key -> Mode +key_mode (_,_,m) = m + +-- | Enumeration of 42 CMN keys. +-- +-- > length key_sequence_42 == 7 * 3 * 2 +key_sequence_42 :: [Key] +key_sequence_42 = + let a_seq = [T.Flat,T.Natural,T.Sharp] + m_seq = [Major_Mode,Minor_Mode] + in [(n,a,m) | n <- T.note_seq,a <- a_seq,m <- m_seq] + +-- | Subset of 'key_sequence' not including very eccentric keys (where +-- there are more than 7 alterations). +-- +-- > length key_sequence_30 == 30 +key_sequence_30 :: [Key] +key_sequence_30 = filter (maybe False ((< 8) . abs) . key_fifths) key_sequence_42 + +-- | Parallel key, ie. 'mode_parallel' of 'Key'. +key_parallel :: Key -> Key +key_parallel (n,a,m) = (n,a,mode_parallel m) + +-- | Transposition of 'Key'. +key_transpose :: Key -> Int -> Key +key_transpose (n,a,m) x = + 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. +-- +-- > let k = [(T.C,T.Natural,Major_Mode),(T.E,T.Natural,Minor_Mode)] +-- > in map (key_lc_uc_pp . key_relative) k == ["a♮","G♮"] +key_relative :: Key -> Key +key_relative k = + case key_mode k of + Major_Mode -> key_parallel (key_transpose k 9) + Minor_Mode -> key_parallel (key_transpose k 3) + +-- | Mediant minor of major key. +-- +-- > key_mediant (T.C,T.Natural,Major_Mode) == Just (T.E,T.Natural,Minor_Mode) +key_mediant :: Key -> Maybe Key +key_mediant k = + case key_mode k of + Major_Mode -> Just (key_parallel (key_transpose k 4)) + _ -> Nothing + +-- > fmap key_pc_set (key_lc_uc_parse "E") +key_pc_set :: Integral i => Key -> [i] +key_pc_set (n,a,md) = + let pc0 = T.note_to_pc n + T.alteration_to_diff_err a + in sort (map ((`mod` 12) . (+ pc0)) (mode_pc_seq md)) + +-- | Pretty-printer where 'Minor_Mode' is written in lower case (lc) and +-- alteration symbol is shown using indicated function. +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 + in c' : a_pp a + +-- | 'key_lc_pp' with unicode (uc) alteration. +-- +-- > map key_lc_uc_pp [(C,Sharp,Minor_Mode),(E,Flat,Major_Mode)] == ["c♯","E♭"] +key_lc_uc_pp :: Key -> String +key_lc_uc_pp = key_lc_pp (return . T.alteration_symbol) + +-- | 'key_lc_pp' with ISO alteration. +key_lc_iso_pp :: Key -> String +key_lc_iso_pp = key_lc_pp T.alteration_iso + +-- | 'key_lc_pp' with tonh alteration. +-- +-- > map key_lc_tonh_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)] +key_lc_tonh_pp :: Key -> String +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) -> [Char] +key_identifier_pp (n,a,m) = map toLower (intercalate "_" [show n,show a,mode_pp m]) + +-- > import Data.Maybe +-- > mapMaybe note_char_to_key "CdEfGaB" +note_char_to_key :: Char -> Maybe Key +note_char_to_key c = + let m = if isUpper c then Major_Mode else Minor_Mode + in fmap (\n -> (n,T.Natural,m)) (T.parse_note_t True c) + +-- | Parse 'Key' from /lc-uc/ string. +-- +-- > let k = mapMaybe key_lc_uc_parse ["c","E","f♯","ab","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] -> with_a n =<< T.symbol_to_alteration_unicode_plus_iso a + _ -> Nothing + -- | Distance along circle of fifths path of indicated 'Key'. A -- positive number indicates the number of sharps, a negative number -- the number of flats. -- --- > key_fifths (A,Natural,Minor_Mode) == 0 --- > key_fifths (A,Natural,Major_Mode) == 3 --- > key_fifths (C,Natural,Minor_Mode) == -3 -key_fifths :: Key -> Int +-- > key_fifths (T.A,T.Natural,Minor_Mode) == Just 0 +-- > key_fifths (T.A,T.Natural,Major_Mode) == Just 3 +-- > key_fifths (T.C,T.Natural,Minor_Mode) == Just (-3) +-- > key_fifths (T.B,T.Sharp,Minor_Mode) == Just 9 +-- > key_fifths (T.E,T.Sharp,Major_Mode) == Just 11 +-- > key_fifths (T.B,T.Sharp,Major_Mode) == Nothing +-- +-- > zip (map key_lc_iso_pp key_sequence_42) (map key_fifths key_sequence_42) +key_fifths :: Key -> Maybe Int key_fifths (n,a,m) = - let cf x = let (p,q) = circle_of_fifths x in p ++ q - eq (Pitch n' a' _) = n == n' && a == a' - (Just ix) = case m of - Major_Mode -> findIndex eq (cf c4) - Minor_Mode -> findIndex eq (cf a4) - in if ix < 13 then negate ix else ix - 12 + let cf x = let (p,q) = T.circle_of_fifths x in p ++ q + eq (T.Pitch n' a' _) = n == n' && a == a' + ix = case m of + Major_Mode -> findIndex eq (cf T.c4) + Minor_Mode -> findIndex eq (cf T.a4) + in fmap (\i -> if i < 13 then negate i else i - 12) ix + +-- | Table mapping 'Key' to 'key_fifths' value. +key_fifths_tbl :: [(Key,Int)] +key_fifths_tbl = + 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'. +-- +-- > let a = [0,1,-1,2,-2,3,-3,4,-4,5,-5] +-- > 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 -> 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) + +-- | Given sorted pitch-class set, find simplest implied key in given mode. +-- +-- > 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 -> [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 -> [i] -> Maybe Int +implied_fifths md = key_fifths <=< implied_key md + +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 -> [i] -> Int +implied_fifths_err md = fromMaybe (error "implied_fifths") . key_fifths . implied_key_err md diff --git a/Music/Theory/List.hs b/Music/Theory/List.hs deleted file mode 100644 --- a/Music/Theory/List.hs +++ /dev/null @@ -1,456 +0,0 @@ --- | List functions. -module Music.Theory.List where - -import Data.Function {- base -} -import Data.List {- base -} -import qualified Data.List.Ordered as O {- data-ordlist -} -import Data.List.Split {- split -} -import Data.Maybe {- base -} - --- | 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 - --- | 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] - --- | 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)] --- > 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 element to end of list. --- --- > close [1..3] == [1,2,3,1] -close :: [a] -> [a] -close x = - case x of - [] -> [] - e:_ -> x ++ [e] - --- | 'adj2' '.' 'close'. --- --- > adj2_cyclic 1 [1..3] == [(1,2),(2,3),(3,1)] -adj2_cyclic :: Int -> [t] -> [(t,t)] -adj2_cyclic n = adj2 n . close - --- | Interleave elements of /p/ and /q/. --- --- > interleave [1..3] [4..6] == [1,4,2,5,3,6] --- > interleave ".+-" "abc" == ".a+b-c" --- > interleave [1..3] [] == [] -interleave :: [b] -> [b] -> [b] -interleave p q = - let u (i,j) = [i,j] - in concatMap u (zip p q) - --- | Variant that continues with the longer input. --- --- > interleave_continue ".+-" "abc" == ".a+b-c" --- > interleave_continue [1..3] [] == [1..3] --- > interleave_continue [] [1..3] == [1..3] -interleave_continue :: [a] -> [a] -> [a] -interleave_continue p q = - case (p,q) of - ([],_) -> q - (_,[]) -> p - (i:p',j:q') -> i : j : interleave_continue p' q' - --- | 'interleave' of 'rotate_left' by /i/ and /j/. --- --- > interleave_rotations 9 3 [1..13] == [10,4,11,5,12,6,13,7,1,8,2,9,3,10,4,11,5,12,6,13,7,1,8,2,9,3] -interleave_rotations :: Int -> Int -> [b] -> [b] -interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s) - --- | Count occurences of elements in list. --- --- > histogram "hohoh" == [('h',3),('o',2)] -histogram :: (Ord a,Integral i) => [a] -> [(a,i)] -histogram x = - let g = group (sort x) - n = map genericLength g - in zip (map head g) n - --- | 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 . chunksOf n - --- * Association lists - --- | Given accesors for /key/ and /value/ collate input. --- --- > let r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")] --- > in collate_on fst snd (zip "ABCBCD" "abcdef") -collate_on :: (Eq k,Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])] -collate_on f g = - let h l = case l of - [] -> error "collate_on" - l0:_ -> (f l0,map g l) - in map h . groupBy ((==) `on` f) . sortBy (compare `on` f) - --- | 'collate_on' of 'fst' and 'snd'. --- --- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")] -collate :: Ord a => [(a,b)] -> [(a,[b])] -collate = collate_on fst snd - --- | 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) - --- | 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'" - --- | Integrate, ie. pitch class segment to interval sequence. --- --- > d_dx [5,6,8,11] == [1,2,3] --- > d_dx [] == [] -d_dx :: (Num a) => [a] -> [a] -d_dx l = if null l then [] else zipWith (-) (tail l) l - --- | Elements of /p/ not in /q/. --- --- > [1,2,3] `difference` [1,2] == [3] -difference :: (Eq a) => [a] -> [a] -> [a] -difference p q = - let f e = e `notElem` q - in filter f p - --- | 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 - --- | 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" - --- | Basis of 'find_bounds'. There is an option to consider the last --- element specially, and if equal to the last span is given. -find_bounds' :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t) -find_bounds' scl f l x = - let g (p,q) = f p x /= GT && f q x == GT - h (p,q) = f p x /= GT && f q x /= LT - h' = if scl then h else g - in case l of - [] -> Nothing - [e] -> if h' e then Just e else Nothing - e:l' -> if g e then Just e else find_bounds' scl f l' x - --- | Find adjacent elements of list that bound element under given --- comparator. --- --- > let {f = find_bounds True compare [1..5] --- > ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]} --- > in map f [0,1,3.5,5] == r -find_bounds :: Bool -> (t -> s -> Ordering) -> [t] -> s -> Maybe (t,t) -find_bounds scl f l = find_bounds' scl f (adj2 1 l) - --- | Variant of 'drop' from right of list. --- --- > 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 - --- | 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 a last element tuple. --- --- > separate_last [1..5] == ([1..4],5) -separate_last :: [a] -> ([a],a) -separate_last x = - let e:x' = reverse x - in (reverse x',e) - --- | 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 - --- | '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 - --- | 'groupBy' on /structure/ of 'Maybe', ie. all 'Just' compare equal. --- --- > let r = [[Just 1],[Nothing,Nothing],[Just 4,Just 5]] --- > in group_just [Just 1,Nothing,Nothing,Just 4,Just 5] == r -group_just :: [Maybe a] -> [[Maybe a]] -group_just = groupBy ((==) `on` isJust) - --- | Predicate to determine if all elements of the list are '=='. -all_eq :: Eq n => [n] -> Bool -all_eq = (== 1) . length . nub - --- | 'groupBy' of 'sortBy'. --- --- > let r = [[('1','a'),('1','c')],[('2','d')],[('3','b'),('3','e')]] --- > in sort_group_on fst (zip "13123" "abcde") == r -sort_group_on :: Ord b => (a -> b) -> [a] -> [[a]] -sort_group_on f = groupBy ((==) `on` f) . sortBy (compare `on` f) - --- | Maybe cons element onto list. --- --- > Nothing `mcons` "something" == "something" --- > Just 's' `mcons` "omething" == "something" -mcons :: Maybe a -> [a] -> [a] -mcons e l = maybe l (:l) e - --- * Ordering - --- | Comparison function type. -type Compare_F a = a -> a -> Ordering - --- | If /f/ compares 'EQ', defer to /g/. -two_stage_compare :: Compare_F a -> Compare_F a -> Compare_F a -two_stage_compare f g p q = - case f p q of - EQ -> g p q - r -> r - --- | Invert 'Ordering'. -ordering_invert :: Ordering -> Ordering -ordering_invert o = - case o of - LT -> GT - EQ -> EQ - GT -> LT - --- | Sort sequence /a/ based on ordering of sequence /b/. --- --- > sort_to "abc" [1,3,2] == "acb" --- > sort_to "adbce" [1,4,2,3,5] == "abcde" -sort_to :: Ord i => [e] -> [i] -> [e] -sort_to e = map fst . sortBy (compare `on` snd) . zip e - --- | 'flip' of 'sort_to'. --- --- > sort_on [1,4,2,3,5] "adbce" == "abcde" -sort_on :: Ord i => [i] -> [e] -> [e] -sort_on = flip sort_to - --- | 'sortBy' of 'two_stage_compare'. -sort_by_two_stage :: (Ord b,Ord c) => (a -> b) -> (a -> c) -> [a] -> [a] -sort_by_two_stage f g = sortBy (two_stage_compare (compare `on` f) (compare `on` g)) - --- | Given a comparison function, merge two ascending lists. --- --- > mergeBy compare [1,3,5] [2,4] == [1..5] -merge_by :: Compare_F a -> [a] -> [a] -> [a] -merge_by = O.mergeBy - --- | 'O.mergeBy' of 'two_stage_compare'. -merge_by_two_stage :: Ord b => (a -> b) -> Compare_F c -> (a -> c) -> [a] -> [a] -> [a] -merge_by_two_stage f cmp g = O.mergeBy (two_stage_compare (compare `on` f) (cmp `on` g)) - --- | 'mergeBy' 'compare'. -merge :: Ord a => [a] -> [a] -> [a] -merge = 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 :: (a -> a -> a) -> Compare_F a -> [a] -> [a] -> [a] -merge_by_resolve jn cmp = - let recur p q = - case (p,q) of - ([],_) -> q - (_,[]) -> p - (l:p',r:q') -> case cmp l r of - LT -> l : recur p' q - EQ -> jn l r : recur p' q' - GT -> r : recur p q' - in recur - --- * Bimap - --- | Apply /f/ to both elements of a two-tuple, ie. 'bimap' /f/ /f/. -bimap1 :: (t -> u) -> (t,t) -> (u,u) -bimap1 f (p,q) = (f p,f q) diff --git a/Music/Theory/List/Logic.hs b/Music/Theory/List/Logic.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/List/Logic.hs @@ -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 + diff --git a/Music/Theory/Math.hs b/Music/Theory/Math.hs deleted file mode 100644 --- a/Music/Theory/Math.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | Math functions. -module Music.Theory.Math where - -import Data.Maybe {- base -} -import Data.Ratio {- base -} -import Numeric {- base -} - --- | Real (alias for 'Double'). -type R = Double - --- | -integral_and_fractional_parts :: (Integral i, RealFrac t) => t -> (i,t) -integral_and_fractional_parts n = - if n >= 0 - then let n' = floor n in (n',n - fromIntegral n') - else let n' = ceiling n in (n',n - fromIntegral n') - --- | Type specialised. -integer_and_fractional_parts :: RealFrac t => t -> (Integer,t) -integer_and_fractional_parts = integral_and_fractional_parts - --- | --- --- > import Sound.SC3.Plot {- hsc3-plot -} --- > plotTable1 (map fractional_part [-2.0,-1.99 .. 2.0]) -fractional_part :: RealFrac a => a -> a -fractional_part = snd . integer_and_fractional_parts - --- | --- --- > plotTable1 (map sawtooth_wave [-2.0,-1.99 .. 2.0]) -sawtooth_wave :: RealFrac a => a -> a -sawtooth_wave n = n - fromInteger (floor n) - --- | Pretty printer for 'Rational' that elides denominators of @1@. --- --- > map rational_pp [1,3/2,2] == ["1","3/2","2"] -rational_pp :: (Show a,Integral a) => Ratio a -> String -rational_pp r = - let n = numerator r - d = denominator r - in if d == 1 - then show n - else concat [show n,"/",show d] - --- | Pretty print ratio as @:@ separated integers. --- --- > map ratio_pp [1,3/2,2] == ["1:1","3:2","2:1"] -ratio_pp :: Rational -> String -ratio_pp r = - let (n,d) = rational_nd r - in concat [show n,":",show d] - --- | Predicate that is true if @n/d@ can be simplified, ie. where --- 'gcd' of @n@ and @d@ is not @1@. --- --- > let r = [False,True,False] --- > in map rational_simplifies [(2,3),(4,6),(5,7)] == r -rational_simplifies :: Integral a => (a,a) -> Bool -rational_simplifies (n,d) = gcd n d /= 1 - --- | 'numerator' and 'denominator' of rational. -rational_nd :: Integral t => Ratio t -> (t,t) -rational_nd r = (numerator r,denominator r) - --- | Rational as a whole number, or 'Nothing'. -rational_whole :: Integral a => Ratio a -> Maybe a -rational_whole r = if denominator r == 1 then Just (numerator r) else Nothing - --- | Erroring variant. -rational_whole_err :: Integral a => Ratio a -> a -rational_whole_err = fromMaybe (error "rational_whole") . rational_whole - --- | Variant of 'showFFloat'. The 'Show' instance for floats resorts --- to exponential notation very readily. --- --- > [show 0.01,realfloat_pp 2 0.01] == ["1.0e-2","0.01"] -realfloat_pp :: RealFloat a => Int -> a -> String -realfloat_pp k n = showFFloat (Just k) n "" - --- | Type specialised 'realfloat_pp'. -float_pp :: Int -> Float -> String -float_pp = realfloat_pp - --- | Type specialised 'realfloat_pp'. -double_pp :: Int -> Double -> String -double_pp = realfloat_pp - --- | Show /only/ positive and negative values, always with sign. --- --- > map num_diff_str [-2,-1,0,1,2] == ["-2","-1","","+1","+2"] --- > map show [-2,-1,0,1,2] == ["-2","-1","0","1","2"] -num_diff_str :: (Num a, Ord a, Show a) => a -> String -num_diff_str n = - case compare n 0 of - LT -> '-' : show (abs n) - EQ -> "" - GT -> '+' : show n diff --git a/Music/Theory/Math/Convert/Fx.hs b/Music/Theory/Math/Convert/Fx.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Convert/Fx.hs @@ -0,0 +1,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 diff --git a/Music/Theory/Math/Nichomachus.hs b/Music/Theory/Math/Nichomachus.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Nichomachus.hs @@ -0,0 +1,53 @@ +{- | Nichomachus of Gerasa (Νικόμαχος) c.60-c.120 + + +-} +module Music.Theory.Math.Nichomachus where + +{- | a-b = b-c ; b = a+c / 2 + +> arithmetic_mean 2 6 == 4 +> arithmetic_mean 1 2 == (1+2)/2 -- 3/2 +-} +arithmetic_mean :: Fractional a => a -> a -> a +arithmetic_mean a c = (a + c) / 2 + +{- | a/b = b/c ; b = sqrt ac + +> geometric_mean 1 4 == 2 +> geometric_mean 1 2 == sqrt (1*2) -- sqrt 2 +-} +geometric_mean :: Floating a => a -> a -> a +geometric_mean a c = sqrt (a * c) + +{- | a-b / a = b-c / c ; 2ac / a+c + +> harmonic_mean 2 6 == 3 +> harmonic_mean 1 2 == (2*1*2)/(1+2) -- 4/3 +-} +harmonic_mean :: Fractional a => a -> a -> a +harmonic_mean a c = (2 * a * c) / (a + c) -- OR -- 2 / (1/a + 1/c) + +{- | a-b / c = b-c / a ; a-b / b-c = c/a ; aa+cc / a+c + +> cont_harmonic_mean 3 6 == 5 +> cont_harmonic_mean 1 2 == (1*1+2*2)/(1+2) -- 5/3 +-} +cont_harmonic_mean :: Fractional a => a -> a -> a +cont_harmonic_mean a c = (a * a + c * c) / (a + c) + +{- | a-b / c = b-c / b ; a-b / b-c = c/b ; c - a + (sqrt (5aa - 2ac + cc)) / 2 + +> cont_geometric_mean 2 5 == 4 +> cont_geometric_mean 1 2 == (2-1+sqrt(5*1*1-2*1*2+2*2))/2 -- (1+sqrt 5)/2 -- GOLDEN RATIO -- 1.6180 +-} +cont_geometric_mean :: Floating a => a -> a -> a +cont_geometric_mean a c = (c - a + sqrt (5 * a * a - 2 * a * c + c * c)) / 2 + +{- | a-b / c = b-c / b ; a-b / b-c = c/b ; a - c + (sqrt (aa - 2ac + 5cc)) / 2 + +> subcont_geometric_mean 1 6 == 4 +> subcont_geometric_mean 1 2 == (-1 + sqrt 17) / 2 -- 1.5616 +-} +subcont_geometric_mean :: Floating a => a -> a -> a +subcont_geometric_mean a c = (a - c + sqrt (a * a - 2 * a * c + 5 * c * c)) / 2 diff --git a/Music/Theory/Math/Oeis.hs b/Music/Theory/Math/Oeis.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Oeis.hs @@ -0,0 +1,1478 @@ +-- | The On-Line Encyclopedia of Integer Sequences, +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 -} + +{- | + +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..] + +{- | + +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])) + +{- | + +The simplest sequence of positive numbers: the all 1's sequence. +-} +a000012 :: Num n => [n] +a000012 = repeat 1 + +{- | + +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 + +{- | + +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) + +{- | + +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 + +{- | + +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 ..] + +{- | + +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) + +{- | + +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 + +{- | + +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) + +{- | + +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))) + +{- | + +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] + +{- | + +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 + +{- | + +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) + +{- | + +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]) + +{- | + +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 + +{- | + +Factorial numbers: n! = 1*2*3*4*...*n +(order of symmetric group S_n, number of permutations of n letters). + +> [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800,479001600,6227020800] `isPrefixOf` a000142 +-} +a000142 :: (Enum n, Num n) => [n] +a000142 = 1 : zipWith (*) [1..] a000142 + +{- | https://oeis.org/A000201 + +Lower Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi), where phi = (1+sqrt(5))/2 = A001622 + +> [1,3,4,6,8,9,11,12,14,16,17,19,21,22,24,25,27,29,30,32,33,35,37,38,40,42] `isPrefixOf` a000201 + +> import Sound.SC3.Plot {- hsc3-plot -} +> plot_p1_imp [take 128 a000201 :: [Int]] +-} +a000201 :: Integral n => [n] +a000201 = + let f (x:xs) (y:ys) = y : f xs (delete (x + y) ys) + f _ _ = error "a000201" + in f [1..] [1..] + +{- | + +Lucas numbers (beginning with 1): L(n) = L(n-1) + L(n-2) with L(1) = 1, L(2) = 3 + +> [1,3,4,7,11,18,29,47,76,123,199,322,521,843,1364,2207,3571,5778,9349,15127] `isPrefixOf` a000204 +-} +a000204 :: Num n => [n] +a000204 = 1 : 3 : zipWith (+) a000204 (tail a000204) + +{- | + +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))) + +{- | + +Triangular numbers: a(n) = binomial(n+1,2) = n(n+1)/2 = 0 + 1 + 2 + ... + n. + +> [0,1,3,6,10,15,21,28,36,45,55,66,78,91,105,120,136,153,171,190,210,231,253,276] `isPrefixOf` a000217 +-} +a000217 :: (Enum n,Num n) => [n] +a000217 = scanl1 (+) [0..] + +{- | + +a(n) = 2^n - 1 (Sometimes called Mersenne numbers, although that name is usually reserved for A001348) + +> [0,1,3,7,15,31,63,127,255,511,1023,2047,4095,8191,16383,32767,65535] `isPrefixOf` a000225 +-} +a000225 :: Num n => [n] +a000225 = iterate ((+ 1) . (* 2)) 0 + +{- | + +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) + +{- | + +The squares of the non-negative integers. + +> [0,1,4,9,16,25,36,49,64,81,100] `isPrefixOf` a000290 +-} +a000290 :: Integral n => [n] +a000290 = let square n = n * n in map square [0..] + +{- | + +Tetrahedral (or triangular pyramidal) numbers: a(n) = C(n+2,3) = n*(n+1)*(n+2)/6. + +> [0,1,4,10,20,35,56,84,120,165,220,286,364,455,560,680,816,969,1140,1330,1540] `isPrefixOf` a000292 +-} +a000292 :: (Enum n,Num n) => [n] +a000292 = scanl1 (+) a000217 + +{- | + +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 + +{- | + +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))) + +{- | + +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 + +{- | + +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)) + +{- | + +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..]]) + +{- | + +Narayana's cows sequence. + +> [1,1,1,2,3,4,6,9,13,19,28,41,60] `isPrefixOf` a000930 +-} +a000930 :: Num n => [n] +a000930 = 1 : 1 : 1 : zipWith (+) a000930 (drop 2 a000930) + +{- | + +Padovan sequence (or Padovan numbers): 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) + +{- | + +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..])) + +{- | + +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 + +{- | + +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..]] + +{- | + +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 + +{- | + +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 ..] + +{- | + +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)) + +{- | + +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 + +{- | + +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) + +{- | + +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 + +{- | + +a(n) = a(n-2) + a(n-5). + +[0,1,0,1,0,1,1,1,2,1,3,2,4,4,5,7,7,11,11,16,18,23,29,34,45,52,68,81,102,126,154] `isPrefixOf` a001687 +-} +a001687 :: Num n => [n] +a001687 = 0 : 1 : 0 : 1 : 0 : zipWith (+) a001687 (drop 3 a001687) + +{- | + +Upper Wythoff sequence (a Beatty sequence): a(n) = floor(n*phi^2), where phi = (1+sqrt(5))/2 + +> [2,5,7,10,13,15,18,20,23,26,28,31,34,36,39,41,44,47,49,52,54,57,60,62,65] `isPrefixOf` a001950 +-} +a001950 :: Integral n => [n] +a001950 = zipWith (+) a000201 [1..] + +-- | +-- +-- The 15 supersingular primes. +a002267 :: Num n => [n] +a002267 = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 41, 47, 59, 71] + +{- | + +Stern's diatomic series (or Stern-Brocot sequence) + +> [0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5] `isPrefixOf` a002487 +-} +a002487 :: Num n => [n] +a002487 = + let f (a:a') (b:b') = a + b : a : f a' b' + f _ _ = error "a002487" + x = 1 : 1 : f (tail x) x + in 0 : x + +{- | + +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 + +{- | + +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 + +{- | + +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..] + +-- | +-- +-- > [0,1,1,1,1,2,3,4,5,7,10,14,19,26,36,50,69,95,131,181,250,345,476,657] `isPrefixOf` a003269 +a003269 :: Num n => [n] +a003269 = 0 : 1 : 1 : 1 : zipWith (+) a003269 (drop 3 a003269) + +{- | + +a(n) = a(n-1) + a(n-5); a(0) = ... = a(4) = 1. + +> [1,1,1,1,1,2,3,4,5,6,8,11,15,20,26,34,45,60,80,106,140,185,245,325,431] `isPrefixOf` a003520 +-} +a003520 :: Num n => [n] +a003520 = 1 : 1 : 1 : 1 : 1 : zipWith (+) a003520 (drop 4 a003520) + +{- | + +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 ^) + +{- | + +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) + +{- | + +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) + +{- | + +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 + +{- | + +Per Nørgård's "infinity sequence" + +> take 32 a004718 == [0,1,-1,2,1,0,-2,3,-1,2,0,1,2,-1,-3,4,1,0,-2,3,0,1,-1,2,-2,3,1,0,3,-2,-4,5] + +> plot_p1_imp [take 1024 a004718] + + + + +-} +a004718 :: Num n => [n] +a004718 = 0 : concat (transpose [map (+ 1) a004718, map negate (tail a004718)]) + +{- | + +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))) + +{- | + +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 + +{- | + +Number of fractions in Farey series of order n. + +> [1,2,3,5,7,11,13,19,23,29,33,43,47,59,65,73,81,97,103,121,129,141,151] `isPrefixOf` a005728 +-} +a005728 :: Integral i => [i] +a005728 = + let phi n = genericLength (filter (==1) (map (gcd n) [1..n])) + f n = if n == 0 then 1 else f (n - 1) + phi n + in map f [0::Integer ..] + +{- | + +Number of runs in binary expansion of n (n>0); number of 1's in Gray code for n + +> take 32 a005811 == [0,1,2,1,2,3,2,1,2,3,4,3,2,3,2,1,2,3,4,3,4,5,4,3,2,3,4,3,2,3,2,1] +-} +a005811 :: Integral n => [n] +a005811 = + let f (x:xs) = x : f (xs ++ [x + x `mod` 2, x + 1 - x `mod` 2]) + f _ = error "A005811" + in 0 : f [1] + +{- | + +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 ..]) + +{- | + +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 + +{- | + +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) + +{- | + +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] + +{- | + +Triangle read by rows: row n gives numerators of Farey series of order n. + +> [0,1,0,1,1,0,1,1,2,1,0,1,1,1,2,3,1,0,1,1,1,2,1,3,2,3,4,1,0,1,1,1,1,2,1,3] `isPrefixOf` a006842 +> plot_p1_imp [take 200 (a006842 :: [Int])] +> plot_p1_pt [take 10000 (a006842 :: [Int])] +-} +a006842 :: Integral i => [i] +a006842 = map numerator (concatMap Math.farey [1..]) + +{- | + +Triangle read by rows: row n gives denominators of Farey series of order n + +> [1,1,1,2,1,1,3,2,3,1,1,4,3,2,3,4,1,1,5,4,3,5,2,5,3,4,5,1,1,6,5,4,3,5,2,5] `isPrefixOf` a006843 +> plot_p1_imp [take 200 (a006843 :: [Int])] +> plot_p1_pt [take 10000 (a006843 :: [Int])] +-} +a006843 :: Integral i => [i] +a006843 = map denominator (concatMap Math.farey [1..]) + +{- | + +Pascal's triangle read by rows + +[[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1],[1,5,10,10,5,1]] `isPrefixOf` a007318_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] + +{- | + +Triangle of Stirling numbers of the second kind, S2(n,k), n >= 1, 1 <= k <= n. + +[1,1,1,1,3,1,1,7,6,1,1,15,25,10,1,1,31,90,65,15,1,1,63,301,350,140,21,1] `isPrefixOf` a008277 +-} +a008277 :: (Enum n,Num n) => [n] +a008277 = concat a008277_tbl + +a008277_tbl :: (Enum n,Num n) => [[n]] +a008277_tbl = map tail a048993_tbl + +{- | + +Triangle of Stirling numbers of 2nd kind, S(n,n-k+1), n >= 1, 1<=k<=n. + +[1,1,1,1,3,1,1,6,7,1,1,10,25,15,1,1,15,65,90,31,1,1,21,140,350,301,63,1] `isPrefixOf` a008278 +-} +a008278 :: (Enum n,Num n) => [n] +a008278 = concat a008278_tbl + +a008278_tbl :: (Enum n,Num n) => [[n]] +a008278_tbl = + let f p = + let q = reverse (zipWith (*) [1..] (reverse p)) + in zipWith (+) (0 : q) (p ++ [0]) + in iterate f [1] + +{- | + +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 + +{- | + +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) + +{- | + +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) + +{- | + +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..] + +{- | + +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..] + +{- | + +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 ..] + +{- | + +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) + +{- | + +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 + +{- | + +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) + +{- | + +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) + +{- | + +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) + +{- | + +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] + +{- | + +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 + +{- | + +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] + +{- | + +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] + +{- | + +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 + +{- | + +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] + +{- | + +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 ..] + +{- | + +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 + +{- | + +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 ..] + +{- | + +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] + +{- | + +Triangle of Stirling numbers of 2nd kind, S(n,k), n >= 0, 0 <= k <= n. + +> [1,0,1,0,1,1,0,1,3,1,0,1,7,6,1,0,1,15,25,10,1,0,1,31,90,65,15,1] `isPrefixOf` a048993 +-} +a048993 :: (Enum n,Num n) => [n] +a048993 = concat a048993_tbl + +a048993_tbl :: (Enum n,Num n) => [[n]] +a048993_tbl = iterate (\row -> 0 : zipWith (+) row (zipWith (*) [1..] (tail row)) ++ [1]) [1] + +{- | + +Triangle read by rows, numerator of fractions of a variant of the Farey series. + +> [0,1,0,1,1,0,1,1,2,1,0,1,1,2,1,3,2,3,1,0,1,1,2,1,3,2,3,1,4,3,5,2,5,3,4,1,0] `isPrefixOf` a049455 +> plot_p1_imp [take 200 (a049455 :: [Int])] +> plot_p1_pt [take 10000 (a049455 :: [Int])] +-} +a049455 :: Integral n => [n] +a049455 = map fst (concat Math.stern_brocot_tree_lhs) + +{- | + +Triangle read by rows, denominator of fractions of a variant of the Farey series. + +[1,1,1,2,1,1,3,2,3,1,1,4,3,5,2,5,3,4,1,1,5,4,7,3,8,5,7,2,7,5,8,3,7,4,5,1,1,6,5,9] `isPrefixOf` a049456 +> plot_p1_imp [take 200 (a049456 :: [Int])] +> plot_p1_pt [take 10000 (a049456 :: [Int])] +-} +a049456 :: Integral n => [n] +a049456 = map snd (concat Math.stern_brocot_tree_lhs) + +{- | + +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] + +{- | + +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)) + +{- | + +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 + +{- | + +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 + +{- | + +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 ..] + +{- | + +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..] + +{- | + +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]) + +{- | + +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] + +{- | + +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..])) + +{- | + +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] + +{- | + +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] + +{- | + +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] + +{- | + +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])) + +{- | + +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 + +{- | + +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]] + +{- | + +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] + +{- | + +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 + +{- | + +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 + +{- | + +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] + +{- | + +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] + +{- | + +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] + +{- | + +A 3 x 3 magic square. +-} +a126654 :: Num n => [n] +a126654 = [32, 4, 24, 12, 20, 28, 16, 36, 8] + +{- | + +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] + +{- | + +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] + +{- | + +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] + +{- | + +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 + +{- | + +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]) + +{- | + +Another variant of Per Nørgård's "infinity sequence" + +> take 24 a255723 == [0,-2,-1,2,-2,-4,1,0,-1,-3,0,1,2,0,-3,4,-2,-4,1,0,-4,-6,3,-2] +> plot_p1_imp [take 400 (a255723 :: [Int])] +-} +a255723 :: Num n => [n] +a255723 = 0 : concat (transpose [map (subtract 2) a255723 + ,map (-1 -) a255723 + ,map (+ 2) a255723 + ,tail a255723]) + +{- | + +First of two variations by Per Nørgård of his "infinity sequence" + +> take 24 a256184 == [0,-2,-1,2,-4,-3,1,-3,-2,-2,0,1,4,-6,-5,3,-5,-4,-1,-1,0,3,-5,-4] +-} +a256184 :: Num n => [n] +a256184 = 0 : concat (transpose [map (subtract 2) a256184 + ,map (subtract 1) a256184 + ,map negate (tail a256184)]) + +{- | + +Second of two variations by Per Nørgård of his "infinity sequence" + +> take 24 a256185 == [0,-3,-2,3,-6,1,2,-5,0,-3,0,-5,6,-9,4,-1,-2,-3,-2,-1,-4,5,-8,3] +-} +a256185 :: Num n => [n] +a256185 = 0 : concat (transpose [map (subtract 3) a256185 + ,map (-2 -) a256185 + ,map negate (tail a256185)]) + +{- | + +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] + +{- | + +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] diff --git a/Music/Theory/Math/Prime.hs b/Music/Theory/Math/Prime.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Math/Prime.hs @@ -0,0 +1,234 @@ +-- | Prime number related functions. +module Music.Theory.Math.Prime where + +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} + +import qualified Data.Numbers.Primes as Primes {- primes -} + +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 '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 = Primes.primes + +-- | 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 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 + +{- | Generate list of factors of /n/ from /x/. + +> factor primes_list 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 == [] +> Primes.primeFactors 1 == [] +-} +factor :: Integral i => [i] -> i -> [i] +factor x n = + case x of + [] -> error "factor: null primes_list input" + i:x' -> if n < i + then [] -- ie. prime factors of 1... + else if i * i > n + then [n] + else if rem n i == 0 + then i : factor x (quot n i) + else factor x' n + +-- | 'factor' of 'primes_list'. +-- +-- > map prime_factors [-1,0,1] == [[],[],[]] +-- > map prime_factors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]] +-- > map Primes.primeFactors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]] +prime_factors :: Integral i => i -> [i] +prime_factors = factor primes_list + +-- | 'maximum' of 'prime_factors' +-- +-- > map prime_limit [243,125] == [3,5] +-- > map prime_limit [0,1] == [1,1] +prime_limit :: Integral i => i -> i +prime_limit x = if x < 2 then 1 else maximum (prime_factors x) + +-- | Collect number of occurences of each element of a sorted list. +-- +-- > multiplicities [1,1,1,2,2,3] == [(1,3),(2,2),(3,1)] +multiplicities :: Eq t => [t] -> [(t,Int)] +multiplicities = List.generic_histogram_by (==) Nothing + +-- | Pretty printer for histogram (multiplicites). +-- +-- > multiplicities_pp [(3,2),(5,1),(7,1)] == "3×2 5×1 7×1" +multiplicities_pp :: Show t => [(t,Int)] -> String +multiplicities_pp = + let f (x,y) = show x ++ "×" ++ show y + in unwords . map f + +-- | 'multiplicities' of '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 . Primes.primeFactors + +-- | 'multiplicities_pp' of 'prime_factors_m'. +prime_factors_m_pp :: (Show i,Integral i) => i -> String +prime_factors_m_pp = multiplicities_pp . prime_factors_m + +-- | Prime factors of /n/ and /d/. +rat_prime_factors :: Integral i => (i,i) -> ([i],[i]) +rat_prime_factors = 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 . Math.rational_nd + +{- | Variant that writes factors of numerator as positive and factors for denominator as negative. + Sorted by absolute value. + +> rat_prime_factors_sgn (3 * 5 * 7 * 11,1) == [3,5,7,11] +> rat_prime_factors_sgn (3 * 5,7 * 11) == [3,5,-7,-11] +> rat_prime_factors_sgn (3 * 7,5) == [3,-5,7] +-} +rat_prime_factors_sgn :: Integral i => (i,i) -> [i] +rat_prime_factors_sgn r = let (n,d) = rat_prime_factors r in sortOn abs (n ++ map negate d) + +-- | Rational variant. +-- +-- > rational_prime_factors_sgn (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 . Math.rational_nd + +-- | The largest prime factor of n/d. +rat_prime_limit :: Integral i => (i,i) -> i +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 . Math.rational_nd + +-- | Merge function for 'rat_prime_factors_m' +rat_pf_merge :: Ord t => [(t,Int)] -> [(t,Int)] -> [(t,Int)] +rat_pf_merge p q = + case (p,q) of + (_,[]) -> p + ([],_) -> map (\(i,j) -> (i,-j)) q + ((a,b):p',(c,d):q') -> + if a < c + then (a,b) : rat_pf_merge p' q + else if a > c + then (c,-d) : rat_pf_merge p q' + else if b /= d + then (a,b-d) : rat_pf_merge p' q' + else rat_pf_merge p' q' + +{- | Collect the prime factors in a rational number given as a +numerator/ denominator pair (n,m). Prime factors are listed in +ascending order with their positive or negative multiplicities, +depending on whether the prime factor occurs in the numerator or the +denominator (after cancelling out common factors). + +> rat_prime_factors_m (1,1) == [] +> rat_prime_factors_m (16,15) == [(2,4),(3,-1),(5,-1)] +> rat_prime_factors_m (10,9) == [(2,1),(3,-2),(5,1)] +> rat_prime_factors_m (81,64) == [(2,-6),(3,4)] +> rat_prime_factors_m (27,16) == [(2,-4),(3,3)] +> rat_prime_factors_m (12,7) == [(2,2),(3,1),(7,-1)] +> rat_prime_factors_m (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 . Math.rational_nd + +-- | 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] +-- > rat_prime_factors_l (2*2*3,7) == [2,1,0,-1] +-- > rat_prime_factors_l (3*3,11*13) == [0,2,0,0,-1,-1] +rat_prime_factors_l :: Integral i => (i,i) -> [Int] +rat_prime_factors_l x = + case rat_prime_factors_m x of + [] -> [] + r -> let lm = maximum (map fst r) + in map (\i -> fromMaybe 0 (lookup i r)) (List.take_until (== lm) primes_list) + +-- | 'Ratio' variant of 'rat_prime_factors_l' +-- +-- > 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 . 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/. +-- +-- > 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 = 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 . 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 + diff --git a/Music/Theory/Maybe.hs b/Music/Theory/Maybe.hs deleted file mode 100644 --- a/Music/Theory/Maybe.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | Extensions to "Data.Maybe". -module Music.Theory.Maybe where - --- import Data.Maybe {- base -} - --- | Variant of unzip. --- --- > let r = ([Just 1,Nothing,Just 3],[Just 'a',Nothing,Just 'c']) --- > in maybe_unzip [Just (1,'a'),Nothing,Just (3,'c')] == r -maybe_unzip :: [Maybe (a,b)] -> ([Maybe a],[Maybe b]) -maybe_unzip = - let f x = case x of - Nothing -> (Nothing,Nothing) - Just (i,j) -> (Just i,Just j) - in unzip . map f - --- | Replace 'Nothing' elements with last 'Just' value. This does not --- alter the length of the list. --- --- > maybe_latch 1 [Nothing,Just 2,Nothing,Just 4] == [1,2,2,4] -maybe_latch :: a -> [Maybe a] -> [a] -maybe_latch i x = - case x of - [] -> [] - Just e:x' -> e : maybe_latch e x' - Nothing:x' -> i : maybe_latch i x' - --- | Variant requiring initial value is not 'Nothing'. --- --- > maybe_latch1 [Just 1,Nothing,Nothing,Just 4] == [1,1,1,4] -maybe_latch1 :: [Maybe a] -> [a] -maybe_latch1 = maybe_latch (error "maybe_latch1") - --- | 'map' of 'fmap'. --- --- > maybe_map negate [Nothing,Just 2] == [Nothing,Just (-2)] -maybe_map :: (a -> b) -> [Maybe a] -> [Maybe b] -maybe_map = map . fmap - --- | If either is 'Nothing' then 'False', else /eq/ of values. -maybe_eq_by :: (t -> u -> Bool) -> Maybe t -> Maybe u -> Bool -maybe_eq_by eq_fn p q = - case (p,q) of - (Just p',Just q') -> eq_fn p' q' - _ -> False - --- | Join two values, either of which may be missing. -maybe_join' :: (s -> t) -> (s -> s -> t) -> Maybe s -> Maybe s -> Maybe t -maybe_join' f g p q = - case (p,q) of - (Nothing,_) -> fmap f q - (_,Nothing) -> fmap f p - (Just p',Just q') -> Just (p' `g` q') - --- | 'maybe_join'' of 'id' -maybe_join :: (t -> t -> t) -> Maybe t -> Maybe t -> Maybe t -maybe_join = maybe_join' id - --- | Apply predicate inside 'Maybe'. --- --- > maybe_predicate even (Just 3) == Nothing -maybe_predicate :: (a -> Bool) -> Maybe a -> Maybe a -maybe_predicate f i = - case i of - Nothing -> Nothing - Just j -> if f j then Just j else Nothing - --- | 'map' of 'maybe_predicate'. --- --- > let r = [Nothing,Nothing,Nothing,Just 4] --- > in maybe_filter even [Just 1,Nothing,Nothing,Just 4] == r -maybe_filter :: (a -> Bool) -> [Maybe a] -> [Maybe a] -maybe_filter = map . maybe_predicate - --- | Variant of 'Data.List.filter' that retains 'Nothing' as a --- placeholder for removed elements. --- --- > filter_maybe even [1..4] == [Nothing,Just 2,Nothing,Just 4] -filter_maybe :: (a -> Bool) -> [a] -> [Maybe a] -filter_maybe f = maybe_filter f . map Just diff --git a/Music/Theory/Meter/Barlow_1987.hs b/Music/Theory/Meter/Barlow_1987.hs --- a/Music/Theory/Meter/Barlow_1987.hs +++ b/Music/Theory/Meter/Barlow_1987.hs @@ -3,53 +3,55 @@ -- Translated by Henning Lohner. module Music.Theory.Meter.Barlow_1987 where -import Data.List -import Data.Numbers.Primes {- primes -} +import Data.List {- base -} --import Debug.Trace -import Music.Theory.Math (R) +import qualified Data.Numbers.Primes as P {- primes -} +import qualified Music.Theory.Math as T {- hmt-base -} + traceShow :: a -> b -> b traceShow _ x = x -- | One indexed variant of 'genericIndex'. -- --- > map (at [11..13]) [1..3] == [11,12,13] -at :: (Integral n) => [a] -> n -> a -at x i = x `genericIndex` (i - 1) +-- > map (at1 [11..13]) [1..3] == [11,12,13] +at1 :: Integral n => [a] -> n -> a +at1 x i = x `genericIndex` (i - 1) --- | Variant of 'at' with boundary rules and specified error message. +-- | Variant of 'at1' with boundary rules and specified error message. -- --- > map (at' 'x' [11..13]) [0..4] == [1,11,12,13,1] --- > at' 'x' [0] 3 == undefined -at' :: (Num a,Show a,Integral n,Show n,Show m) => m -> [a] -> n -> a -at' m x i = +-- > map (at1_bnd_err 'x' [11..13]) [0..4] == [1,11,12,13,1] +-- > at1_bnd_err 'x' [0] 3 == undefined +at1_bnd_err :: (Num a,Show a,Integral n,Show n,Show m) => m -> [a] -> n -> a +at1_bnd_err m x i = let n = genericLength x in if i == 0 || i == n + 1 then 1 -- error (show ("at':==",m,x,i)) else if i < 0 || i > n + 1 - then error (show ("at'",m,x,i)) + then error (show ("at1_bnd_err",m,x,i)) else x `genericIndex` (i - 1) -- | Variant of 'mod' with input constraints. -- --- > mod' (-1) 2 == 1 -mod' :: (Integral a,Show a) => a -> a -> a -mod' a b = +-- > mod_pos_err (-1) 2 == 1 +-- > mod_pos_err 1 (-2) == undefined +mod_pos_err :: (Integral a,Show a) => a -> a -> a +mod_pos_err a b = let r = mod a b in if r < 0 || r >= b - then error (show ("mod'",a,b,r)) + then error (show ("mod_pos_err",a,b,r)) else r --- | Specialised variant of 'fromIntegral'. -to_r :: (Integral n,Show n) => n -> R +-- | Type-specialised variant of 'fromIntegral'. +to_r :: Integral n => n -> Double to_r = fromIntegral -- | Variant on 'div' with input constraints. -div' :: (Integral a,Show a) => String -> a -> a -> a -div' m i j = +div_pos_err :: (Integral a,Show a) => String -> a -> a -> a +div_pos_err m i j = if i < 0 || j < 0 - then error (show ("div'",m,i,j)) + then error (show ("div_pos_err",m,i,j)) else truncate (to_r i / to_r j) -- | A stratification is a tree of integral subdivisions. @@ -76,23 +78,24 @@ lower_psi q z n = let s8 r = let s1 = product q - s2 = (n - 2) `mod'` s1 - s3 = let f k = at' "s3" q (z + 1 - k) + s2 = (n - 2) `mod_pos_err` s1 + s3 = let f k = at1_bnd_err "s3" q (z + 1 - k) in product (map f [0 .. r]) - s4 = 1 + div' "s4" s2 s3 - c = at' "c" q (z - r) - s5 = s4 `mod'` c + s4 = 1 + div_pos_err "s4" s2 s3 + c = at1_bnd_err "c" q (z - r) + s5 = s4 `mod_pos_err` c s6 = upper_psi c (1 + s5) - s7 = let f = at' "s7" q + s7 = let f = at1_bnd_err "s7" q in product (map f [0 .. z - r - 1]) in traceShow ("lower_psi:s",s1,s2,s3,s4,s5,s6,s7) (s7 * s6) in traceShow ("lower_psi",q,z,n) (sum (map s8 [0 .. z - 1])) --- | The first /n/th primes, reversed. +-- | The first /n/ primes, reversed. -- -- > reverse_primes 14 == [43,41,37,31,29,23,19,17,13,11,7,5,3,2] -reverse_primes :: (Integral n,Show n) => n -> [n] -reverse_primes n = reverse (genericTake n primes) +-- > length (reverse_primes 14) == 14 +reverse_primes :: Integral n => n -> [n] +reverse_primes n = reverse (genericTake n P.primes) -- | Generate prime stratification for /n/. -- @@ -105,7 +108,7 @@ let go x k = case x of p:x' -> if k `rem` p == 0 - then p : go x (div' "ps" k p) + then p : go x (div_pos_err "ps" k p) else go x' k [] -> [] in go (reverse_primes 14) @@ -125,8 +128,8 @@ else if p == 2 then p - n else if n == p - 1 - then div' "upper_psi" p 4 - else let n' = n - div' "n'" n p + then div_pos_err "upper_psi" p 4 + else let n' = n - div_pos_err "n'" n p s = prime_stratification (p - 1) q = lower_psi s (genericLength s) n' q' = to_r q @@ -179,7 +182,7 @@ -- @(0,1)@. -- -- relative_indispensibilities [3,2] == [1,0,0.6,0.2,0.8,0.4] -relative_indispensibilities :: (Integral n,Show n) => Stratification n -> [R] +relative_indispensibilities :: (Integral n,Show n) => Stratification n -> [Double] relative_indispensibilities = relative_to_length . indispensibilities -- | Align two meters (given as stratifications) to least common @@ -209,7 +212,7 @@ -- | Type pairing a stratification and a tempo. type S_MM t = ([t],t) --- | Variant of 'div' that requires 'mod' be @0@. +-- | Variant of 'div' that requires 'mod_pos_err be @0@. whole_div :: Integral a => a -> a -> a whole_div i j = case i `divMod` j of @@ -242,18 +245,6 @@ s2' = s2 ++ prime_stratification (t `whole_div` t2) in (s1',s2') --- | Arithmetic mean (average) of a list. --- --- > mean [0..5] == 2.5 -mean :: Fractional a => [a] -> a -mean x = sum x / fromIntegral (length x) - --- | Square of /n/. --- --- > square 5 == 25 -square :: Num a => a -> a -square n = n * n - -- | Composition of 'prolong_stratifications' and 'align_meters'. -- -- > align_s_mm indispensibilities ([2,2,3],5) ([3,5],4) @@ -274,15 +265,15 @@ upper_psi' h n = if h > 3 then let omega x = if x == 0 then 0 else 1 - h4 = div' "h4" h 4 + h4 = div_pos_err "h4" h 4 n' = n - 1 + omega (h - n) p = prime_stratification (h - 1) x0 = lower_psi p (genericLength p) n' - x1 = x0 + omega (div' "z" x0 h4) + x1 = x0 + omega (div_pos_err "z" x0 h4) x2 = omega (h - n - 1) x3 = x2 + h4 * (1 - x2) in traceShow ("upper_psi'",h,n,n',x0,x1,x2,x3) (x1 * x3) - else (h + n - 2) `mod'` h + else (h + n - 2) `mod_pos_err` h -- | The /MPS/ limit equation given on p.58. -- @@ -301,9 +292,9 @@ -- > mean_square_product [(2,3),(4,5)] == (6^2 + 20^2) / 2^2 mean_square_product :: Fractional n => [(n,n)] -> n mean_square_product x = - let f = square . uncurry (*) + let f = T.square . uncurry (*) n = fromIntegral (length x) - in sum (map f x) / square n + in sum (map f x) / T.square n -- | An incorrect attempt at the description in paragraph two of p.58 -- of the /CMJ/ paper. @@ -311,7 +302,7 @@ -- > let p ~= q = abs (p - q) < 1e-4 -- > metrical_affinity [2,3] 1 [3,2] 1 ~= 0.0324 -- > metrical_affinity [2,2,3] 20 [3,5] 16 ~= 0.0028 -metrical_affinity :: (Integral n,Show n) => [n] -> n -> [n] -> n -> R +metrical_affinity :: (Integral n,Show n) => [n] -> n -> [n] -> n -> Double metrical_affinity s1 v1 s2 v2 = let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2) i1 = relative_indispensibilities s1' @@ -331,7 +322,7 @@ -- > metrical_affinity' [2,2,2] 1 [3,2,2] 1 ~= 0.45872 -- -- > metrical_affinity' [3,2,2] 3 [2,2,3] 2 ~= 0.10282 -metrical_affinity' :: (Integral t,Show t) => [t] -> t -> [t] -> t -> R +metrical_affinity' :: (Integral t,Show t) => [t] -> t -> [t] -> t -> Double metrical_affinity' s1 v1 s2 v2 = let (s1',s2') = prolong_stratifications (s1,v1) (s2,v2) ix :: (Integer -> x) -> Integer -> x @@ -339,20 +330,20 @@ 1 -> f 1 2 -> f 2 _ -> error (show ("ix",i)) - s = ix (at [s1,s2]) - v = ix (at [v1,v2]) + s = ix (at1 [s1,s2]) + v = ix (at1 [v1,v2]) u = ix (genericLength . s) - s' = ix (at [s1',s2']) + s' = ix (at1 [s1',s2']) z = ix (genericLength . s') - q i j = s i `at` j + q i j = s i `at1` j omega_u i = product (map (q i) [1::Int .. u i]) omega_z _ = lcm (v 1 * omega_u 1) (v 2 * omega_u 2) omega_0 = lcm (product (s' 1)) (product (s' 2)) - x0 n i = lower_psi (s' i) (z i) (1 + ((n - 1) `mod'` omega_z i)) - x1 n = square (product (map (x0 n) [1,2])) + x0 n i = lower_psi (s' i) (z i) (1 + ((n - 1) `mod_pos_err` omega_z i)) + x1 n = T.square (product (map (x0 n) [1,2])) x2 = sum (map x1 [1 .. omega_0]) x3 = 18 * x2 - 2 - x4 i = square (omega_z i - 1) + x4 i = T.square (omega_z i - 1) x5 = product (map x4 [1::Integer,2]) x6 = 7 * omega_0 * x5 x7 = to_r x3 / to_r x6 diff --git a/Music/Theory/Metric/Buchler_1998.hs b/Music/Theory/Metric/Buchler_1998.hs --- a/Music/Theory/Metric/Buchler_1998.hs +++ b/Music/Theory/Metric/Buchler_1998.hs @@ -3,13 +3,14 @@ -- thesis, University of Rochester, 1998 module Music.Theory.Metric.Buchler_1998 where +import Data.Int {- base -} import Data.List {- base -} import Data.Ratio {- base -} import qualified Music.Theory.List as T -import qualified Music.Theory.Z12.Forte_1973 as T +import qualified Music.Theory.Z as T +import qualified Music.Theory.Z.Forte_1973 as T import qualified Music.Theory.Set.List as T -import Music.Theory.Z12 (Z12) -- | Predicate for list with cardinality /n/. of_c :: Integral n => n -> [a] -> Bool @@ -18,7 +19,7 @@ -- | Set classes of cardinality /n/. -- -- > sc_table_n 2 == [[0,1],[0,2],[0,3],[0,4],[0,5],[0,6]] -sc_table_n :: (Integral n) => n -> [[Z12]] +sc_table_n :: (Integral n) => n -> [[Int8]] sc_table_n n = filter (of_c n) (map snd T.sc_table) -- | Minima and maxima of ICV of SCs of cardinality /n/. @@ -27,7 +28,7 @@ icv_minmax :: (Integral n, Integral b) => n -> ([b], [b]) icv_minmax n = let t = sc_table_n n - i = transpose (map T.icv t) + i = transpose (map (T.z_icv T.z12) t) in (map minimum i,map maximum i) data R = MIN | MAX deriving (Eq,Show) @@ -43,10 +44,10 @@ MAX -> "-" -- | 'SATV' element measure with given funtion. -satv_f :: (Integral n) => ((n,n,n) -> D n) -> [Z12] -> [D n] +satv_f :: (Integral n) => ((n,n,n) -> D n) -> [Int8] -> [D n] satv_f f p = let n = length p - i = T.icv p + i = T.z_icv T.z12 p (l,r) = icv_minmax n in map f (zip3 l i r) @@ -68,7 +69,7 @@ -- -- > satv_e_pp (satv_a [0,1,2,6,7,8]) == "<-1,+2,+0,+0,-1,-0>" -- > satv_e_pp (satv_a [0,1,2,3,4]) == "<-0,-1,-2,+0,+0,+0>" -satv_a :: Integral i => [Z12] -> [D i] +satv_a :: Integral i => [Int8] -> [D i] satv_a = let f (l,i,r) = let l' = abs (i - l) r' = abs (i - r) @@ -81,7 +82,7 @@ -- -- > satv_e_pp (satv_b [0,1,2,6,7,8]) == "<+4,-4,-5,-4,+4,+3>" -- > satv_e_pp (satv_b [0,1,2,3,4]) == "<+4,+3,+2,-3,-4,-2>" -satv_b :: Integral i => [Z12] -> [D i] +satv_b :: Integral i => [Int8] -> [D i] satv_b = let f (l,i,r) = let l' = abs (i - l) r' = abs (i - r) @@ -102,7 +103,7 @@ -- > satv_pp (satv [0,1,2,3,4,6]) == "(<-1,-2,-2,+0,+1,+1>,<+4,+4,+3,-4,-4,-2>)" -- > satv_pp (satv [0,1,3,6,8]) == "(<+1,-2,-2,+0,-1,-1>,<-3,+2,+2,-3,+3,+1>)" -- > satv_pp (satv [0,2,3,5,7,9]) == "(<+1,-2,-2,+0,-1,+1>,<-4,+4,+3,-4,+4,-2>)" -satv :: Integral i => [Z12] -> SATV i +satv :: Integral i => [Int8] -> SATV i satv p = (satv_a p,satv_b p) -- | 'SATV' reorganised by 'R'. @@ -120,7 +121,7 @@ -- | Sum of numerical components of @a@ and @b@ parts of 'SATV'. -- -- > satv_n_sum (satv [0,1,2,6,7,8]) == [5,6,5,4,5,3] --- > satv_n_sum (satv [0,3,6,9]) = [3,3,4,3,3,2] +-- > satv_n_sum (satv [0,3,6,9]) == [3,3,4,3,3,2] satv_n_sum :: Num c => SATV c -> [c] satv_n_sum (i,j) = zipWith (+) (map snd i) (map snd j) @@ -148,7 +149,7 @@ -- > satsim [0,1,2,3,4] [0,1,4,5,7] == 8/21 -- > satsim [0,1,2,3,4] [0,2,4,6,8] == 4/7 -- > satsim [0,1,4,5,7] [0,2,4,6,8] == 4/7 -satsim :: Integral a => [Z12] -> [Z12] -> Ratio a +satsim :: Integral a => [Int8] -> [Int8] -> Ratio a satsim p q = let i = satv p j = satv q @@ -161,7 +162,7 @@ -- | Table of 'satsim' measures for all @SC@ pairs. -- -- > length satsim_table == 24310 -satsim_table :: Integral i => [(([Z12],[Z12]),Ratio i)] +satsim_table :: Integral i => [(([Int8],[Int8]),Ratio i)] satsim_table = let f (i,j) = ((i,j),satsim i j) t = filter ((`notElem` [0,1,12]) . length) (map snd T.sc_table) diff --git a/Music/Theory/Metric/Morris_1980.hs b/Music/Theory/Metric/Morris_1980.hs --- a/Music/Theory/Metric/Morris_1980.hs +++ b/Music/Theory/Metric/Morris_1980.hs @@ -2,19 +2,21 @@ -- Sets\". Perspectives of New Music, 18(2):445-460, 1980. module Music.Theory.Metric.Morris_1980 where -import Data.Ratio -import Music.Theory.Z12 -import Music.Theory.Z12.Forte_1973 +import Data.Int {- base -} +import Data.Ratio {- base -} +import Music.Theory.Z {- hmt -} +import Music.Theory.Z.Forte_1973 {- hmt -} + -- | SIM -- --- > icv [0,1,3,6] == [1,1,2,0,1,1] && icv [0,2,4,7] == [0,2,1,1,2,0] +-- > icv 12 [0,1,3,6] == [1,1,2,0,1,1] && icv 12 [0,2,4,7] == [0,2,1,1,2,0] -- > sim [0,1,3,6] [0,2,4,7] == 6 -- > sim [0,1,2,4,5,8] [0,1,3,7] == 9 -sim :: Integral a => [Z12] -> [Z12] -> a +sim :: Integral a => [Int8] -> [Int8] -> a sim r s = - let r' = icv r - s' = icv s + let r' = z_icv z12 r + s' = z_icv z12 s t = zipWith (-) r' s' in sum (map abs t) @@ -25,8 +27,8 @@ -- > asim [0,1,2,3,4] [0,1,4,5,7] == 2/5 -- > asim [0,1,2,3,4] [0,2,4,6,8] == 3/5 -- > asim [0,1,4,5,7] [0,2,4,6,8] == 3/5 -asim :: (Integral n) => [Z12] -> [Z12] -> Ratio n +asim :: (Integral n) => [Int8] -> [Int8] -> Ratio n asim r s = - let r' = icv r - s' = icv s + let r' = z_icv z12 r + s' = z_icv z12 s in sim r s % (sum r' + sum s') diff --git a/Music/Theory/Metric/Polansky_1996.hs b/Music/Theory/Metric/Polansky_1996.hs --- a/Music/Theory/Metric/Polansky_1996.hs +++ b/Music/Theory/Metric/Polansky_1996.hs @@ -1,15 +1,16 @@ --- | Larry Polansky. \"Morphological Metrics\". Journal of New Music --- Research, 25(4):289-368, 1996. +-- | Larry Polansky. \"Morphological Metrics\". +-- Journal of New Music Research, 25(4):289-368, 1996. module Music.Theory.Metric.Polansky_1996 where -import Data.List -import Data.Maybe -import Data.Ratio -import qualified Music.Theory.Contour.Polansky_1992 as C -import qualified Music.Theory.List as L +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} --- | Distance function, ordinarily /n/ below is in 'Num', 'Fractional' --- or 'Real'. +import qualified Music.Theory.List as L {- hmt-base -} + +import qualified Music.Theory.Contour.Polansky_1992 as C {- hmt -} + +-- | Distance function, ordinarily /n/ below is in 'Num', 'Fractional' or 'Real'. type Interval a n = (a -> a -> n) -- | 'fromIntegral' '.' '-'. @@ -21,43 +22,43 @@ dif_r i j = realToFrac (i - j) -- | 'abs' '.' /f/. -abs_dif :: Num n => Interval a n -> a -> a -> n -abs_dif f i j = abs (i `f` j) +abs_of :: Num n => Interval a n -> a -> a -> n +abs_of f i j = abs (i `f` j) -- | Square. sqr :: Num a => a -> a sqr n = n * n -- | 'sqr' '.' /f/. -sqr_dif :: Num n => Interval a n -> a -> a -> n -sqr_dif f i j = sqr (i `f` j) +sqr_of :: Num n => Interval a n -> a -> a -> n +sqr_of f i j = sqr (i `f` j) -- | 'sqr' '.' 'abs' '.' /f/. -sqr_abs_dif :: Num n => Interval a n -> a -> a -> n -sqr_abs_dif f i = sqr . abs_dif f i +sqr_abs_of :: Num n => Interval a n -> a -> a -> n +sqr_abs_of f i = sqr . abs_of f i -- | 'sqrt' '.' 'abs' '.' /f/. -sqrt_abs_dif :: Floating c => Interval a c -> a -> a -> c -sqrt_abs_dif f i = sqrt . abs_dif f i +sqrt_abs_of :: Floating c => Interval a c -> a -> a -> c +sqrt_abs_of f i = sqrt . abs_of f i -- | City block metric, p.296 -- -- > city_block_metric (-) (1,2) (3,5) == 2+3 city_block_metric :: Num n => Interval a n -> (a,a) -> (a,a) -> n -city_block_metric f (x1,x2) (y1,y2) = abs_dif f x1 y1 + abs_dif f x2 y2 +city_block_metric f (x1,x2) (y1,y2) = abs_of f x1 y1 + abs_of f x2 y2 -- | Two-dimensional euclidean metric, p.297. -- -- > euclidean_metric_2 (-) (1,2) (3,5) == sqrt (4+9) euclidean_metric_2 :: Floating n => Interval a n -> (a,a) -> (a,a) -> n -euclidean_metric_2 f (x1,x2) (y1,y2) = sqrt (sqr_dif f x1 y1 + sqr_dif f x2 y2) +euclidean_metric_2 f (x1,x2) (y1,y2) = sqrt (sqr_of f x1 y1 + sqr_of f x2 y2) -- | /n/-dimensional euclidean metric -- -- > euclidean_metric_l (-) [1,2] [3,5] == sqrt (4+9) -- > euclidean_metric_l (-) [1,2,3] [2,4,6] == sqrt (1+4+9) euclidean_metric_l :: Floating c => Interval b c -> [b] -> [b] -> c -euclidean_metric_l f p = sqrt . sum . zipWith (sqr_dif f) p +euclidean_metric_l f p = sqrt . sum . zipWith (sqr_of f) p -- | Cube root. -- @@ -89,19 +90,12 @@ let g i j = abs (i `f` j) ** n in nthrt n (sum (zipWith g p q)) --- | Integration with /f/. --- --- > d_dx (-) [0,2,4,1,0] == [2,2,-3,-1] --- > d_dx (-) [2,3,0,4,1] == [1,-3,4,-3] -d_dx :: Interval a n -> [a] -> [n] -d_dx f l = zipWith f (tail l) l - --- | 'map' 'abs' '.' 'd_dx'. +-- | 'map' 'abs' '.' 'L.d_dx_by'. -- -- > d_dx_abs (-) [0,2,4,1,0] == [2,2,3,1] -- > d_dx_abs (-) [2,3,0,4,1] == [1,3,4,3] d_dx_abs :: Num n => Interval a n -> [a] -> [n] -d_dx_abs f = map abs . d_dx f +d_dx_abs f = map abs . L.d_dx_by f -- | Ordered linear magnitude (no delta), p.300 -- @@ -114,11 +108,11 @@ -- | Ordered linear magintude (general form) p.302 -- --- > olm_general (abs_dif (-)) [0,2,4,1,0] [2,3,0,4,1] == 1.25 --- > olm_general (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6 -olm_general :: (Fractional a,Enum a,Fractional n) => Interval a n -> [a] -> [a] -> n +-- > olm_general (abs_of (-)) [0,2,4,1,0] [2,3,0,4,1] == 1.25 +-- > olm_general (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6 +olm_general :: Fractional n => Interval a n -> [a] -> [a] -> n olm_general f p q = - let r = zipWith (-) (d_dx f p) (d_dx f q) + let r = zipWith (-) (L.d_dx_by f p) (L.d_dx_by f q) z = sum (map abs r) in z / (fromIntegral (length p) - 1) @@ -149,9 +143,9 @@ -- | Ordered linear magintude (generalised-interval form) p.305 -- --- > olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6 --- > olm (abs_dif dif_r) (abs_ix_dif dif_r) maximum [1,5,12,2,9,6] [7,6,4,9,8,1] == 0.46 -olm :: (Fractional a,Enum a) => Psi a -> Delta n a -> ([a] -> a) -> [n] -> [n] -> a +-- > olm (abs_of dif_r) (abs_ix_dif dif_r) (const 1) [1,5,12,2,9,6] [7,6,4,9,8,1] == 4.6 +-- > olm (abs_of dif_r) (abs_ix_dif dif_r) maximum [1,5,12,2,9,6] [7,6,4,9,8,1] == 0.46 +olm :: Fractional a => Psi a -> Delta n a -> ([a] -> a) -> [n] -> [n] -> a olm psi delta maxint m n = let l = length m l' = fromIntegral l - 1 @@ -162,23 +156,23 @@ -- > olm_no_delta [0,2,4,1,0] [2,3,0,4,1] == 1.25 -- > olm_no_delta [1,6,2,5,11] [3,15,13,2,9] == 4.5 -olm_no_delta :: (Real a,Real n,Enum n,Fractional n) => [a] -> [a] -> n -olm_no_delta = olm (abs_dif dif_r) (abs_ix_dif dif_r) (const 1) +olm_no_delta :: (Real a,Real n,Fractional n) => [a] -> [a] -> n +olm_no_delta = olm (abs_of dif_r) (abs_ix_dif dif_r) (const 1) -- > olm_no_delta_squared [0,2,4,1,0] [2,3,0,4,1] == sum (map sqrt [3,5,7,8]) / 4 -olm_no_delta_squared :: (Enum a,Floating a) => [a] -> [a] -> a -olm_no_delta_squared = olm (sqrt_abs_dif (-)) (sqr_abs_ix_dif (-)) (const 1) +olm_no_delta_squared :: Floating a => [a] -> [a] -> a +olm_no_delta_squared = olm (sqrt_abs_of (-)) (sqr_abs_ix_dif (-)) (const 1) second_order :: (Num n) => ([n] -> [n] -> t) -> [n] -> [n] -> t second_order f p q = f (d_dx_abs (-) p) (d_dx_abs (-) q) -- > olm_no_delta_second_order [0,2,4,1,0] [2,3,0,4,1] == 1.0 -olm_no_delta_second_order :: (Real a,Enum a,Fractional a) => [a] -> [a] -> a +olm_no_delta_second_order :: (Real a,Fractional a) => [a] -> [a] -> a olm_no_delta_second_order = second_order olm_no_delta -- p.301 erroneously gives this as sum (map sqrt [2,0,1]) / 3 -- > olm_no_delta_squared_second_order [0,2,4,1,0] [2,3,0,4,1] == sum (map sqrt [4,0,3]) / 3 -olm_no_delta_squared_second_order :: (Enum a,Floating a) => [a] -> [a] -> a +olm_no_delta_squared_second_order :: Floating a => [a] -> [a] -> a olm_no_delta_squared_second_order = second_order olm_no_delta_squared -- | Second order binomial coefficient, p.307 @@ -187,19 +181,19 @@ second_order_binonial_coefficient :: Fractional a => a -> a second_order_binonial_coefficient n = ((n * n) - n) / 2 --- | 'd_dx' of 'flip' 'compare'. +-- | 'L.d_dx_by' of 'flip' 'compare'. -- -- > direction_interval [5,9,3,2] == [LT,GT,GT] -- > direction_interval [2,5,6,6] == [LT,LT,EQ] direction_interval :: Ord i => [i] -> [Ordering] -direction_interval = d_dx (flip compare) +direction_interval = L.d_dx_by (flip compare) -- | Histogram of list of 'Ordering's. -- -- > ord_hist [LT,GT,GT] == (1,0,2) ord_hist :: Integral t => [Ordering] -> (t,t,t) ord_hist x = - let h = L.histogram x + let h = L.generic_histogram x f n = fromMaybe 0 (lookup n h) in (f LT,f EQ,f GT) @@ -219,7 +213,7 @@ let (i,j,k) = direction_vector m (p,q,r) = direction_vector n z = (i + j + k) * 2 - in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z + in (abs_of (-) i p + abs_of (-) j q + abs_of (-) k r) % z -- | Ordered linear direction, p.312 -- @@ -256,30 +250,27 @@ let (i,j,k) = ord_hist (concat (C.half_matrix_f compare m)) (p,q,r) = ord_hist (concat (C.half_matrix_f compare n)) z = (i + j + k) * 2 - in (abs_dif (-) i p + abs_dif (-) j q + abs_dif (-) k r) % z + in (abs_of (-) i p + abs_of (-) j q + abs_of (-) k r) % z -- | 'C.half_matrix_f', Fig.9, p.318 -- --- > let r = [[2,3,1,4] --- > ,[1,3,6] --- > ,[4,7] --- > ,[3]] --- > in combinatorial_magnitude_matrix (abs_dif (-)) [5,3,2,6,9] == r +-- > let r = [[2,3,1,4],[1,3,6],[4,7],[3]] +-- > combinatorial_magnitude_matrix (abs_of (-)) [5,3,2,6,9] == r combinatorial_magnitude_matrix :: Interval a n -> [a] -> [[n]] combinatorial_magnitude_matrix = C.half_matrix_f -- | Unordered linear magnitude (simplified), p.320-321 -- -- > let r = abs (sum [5,4,3,6] - sum [12,2,11,7]) / 4 --- > in ulm_simplified (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == r +-- > ulm_simplified (abs_of (-)) [1,6,2,5,11] [3,15,13,2,9] == r -- --- > ulm_simplified (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3 +-- > ulm_simplified (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3 ulm_simplified :: Fractional n => Interval a n -> [a] -> [a] -> n ulm_simplified f p q = - let g = abs . sum . d_dx f + let g = abs . sum . L.d_dx_by f in abs (g p - g q) / fromIntegral (length p - 1) -ocm_zcm :: (Fractional n, Num a) => Interval a n -> [a] -> [a] -> (n, n, [n]) +ocm_zcm :: Fractional n => Interval a n -> [a] -> [a] -> (n, n, [n]) ocm_zcm f p q = let p' = concat (C.half_matrix_f f p) q' = concat (C.half_matrix_f f q) @@ -291,18 +282,18 @@ -- | Ordered combinatorial magnitude (OCM), p.323 -- --- > ocm (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 5.2 --- > ocm (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3.6 -ocm :: (Fractional a,Enum a,Fractional n) => Interval a n -> [a] -> [a] -> n +-- > ocm (abs_of (-)) [1,6,2,5,11] [3,15,13,2,9] == 5.2 +-- > ocm (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 3.6 +ocm :: Fractional n => Interval a n -> [a] -> [a] -> n ocm f p q = let (z,c,_) = ocm_zcm f p q in z / c -- | Ordered combinatorial magnitude (OCM), p.323 -- --- > ocm_absolute_scaled (abs_dif (-)) [1,6,2,5,11] [3,15,13,2,9] == 0.4 --- > ocm_absolute_scaled (abs_dif (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 54/(15*11) -ocm_absolute_scaled :: (Ord a,Fractional a,Enum a,Ord n,Fractional n) => Interval a n -> [a] -> [a] -> n +-- > ocm_absolute_scaled (abs_of (-)) [1,6,2,5,11] [3,15,13,2,9] == 0.4 +-- > ocm_absolute_scaled (abs_of (-)) [1,5,12,2,9,6] [7,6,4,9,8,1] == 54/(15*11) +ocm_absolute_scaled :: (Ord n,Fractional n) => Interval a n -> [a] -> [a] -> n ocm_absolute_scaled f p q = let (z,c,m) = ocm_zcm f p q in z / (c * maximum m) diff --git a/Music/Theory/Parse.hs b/Music/Theory/Parse.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Parse.hs @@ -0,0 +1,27 @@ +-- | Parsing utilities +module Music.Theory.Parse where + +import Data.Maybe {- base -} + +import qualified Text.Parsec as P {- parsec -} +import qualified Text.Parsec.String as P {- parsec -} + +-- | A 'Char' parser. +type P a = P.GenParser Char () a + +-- | Boolean 'P' for given 'Char'. +is_char :: Char -> P Bool +is_char = fmap isJust . P.optionMaybe . P.char + +-- | 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 diff --git a/Music/Theory/Permutations.hs b/Music/Theory/Permutations.hs deleted file mode 100644 --- a/Music/Theory/Permutations.hs +++ /dev/null @@ -1,158 +0,0 @@ --- | Permutation functions. -module Music.Theory.Permutations where - -import qualified Data.Permute as P {- permutation -} -import Numeric (showHex) {- base -} - -import qualified Music.Theory.List as L - --- | 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. --- --- > (nk_permutations 4 3,nk_permutations 13 3) == (24,1716) -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 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 [0,1,3] [1,0,3]) [0,1,3] == [1,0,3] -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] --- > in apply_permutation p [1..4] == [4,3,2,1] -apply_permutation :: (Eq a) => 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 :: (Eq a) => [[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] --- > in 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/. --- --- > map one_line (permutations_n 3) == [[1,2,3],[1,3,2] --- > ,[2,1,3],[2,3,1] --- > ,[3,1,2],[3,2,1]] -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]] --- > ;q = from_cycles [[0,1,4],[2,3]] --- > ;r = p `compose` q} --- > in apply_permutation r [1,2,3,4,5] == [2,4,5,1,3] -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] --- --- > map one_line (permutations_n 3) == [[1,2,3],[1,3,2] --- > ,[2,1,3],[2,3,1] --- > ,[3,1,2],[3,2,1]] -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 --- > in unwords (map one_line_compact p) == "123 132 213 231 312 321" -one_line_compact :: P.Permute -> String -one_line_compact = - let f n = if n >= 0 && n <= 15 - then showHex n "" - 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) -partition not (map non_invertible (permutations_n 4)) --} diff --git a/Music/Theory/Permutations/List.hs b/Music/Theory/Permutations/List.hs --- a/Music/Theory/Permutations/List.hs +++ b/Music/Theory/Permutations/List.hs @@ -1,20 +1,46 @@ -- | List permutation functions. module Music.Theory.Permutations.List where -import qualified Math.Combinatorics.Multiset as C -import qualified Music.Theory.Permutations as P +import Data.List {- base -} +import qualified Math.Combinatorics.Multiset as C {- multiset-comb -} + +import qualified Music.Theory.Permutations as P {- hmt-base -} + -- | Generate all permutations. -- --- > permutations [0,3] == [[0,3],[3,0]] --- > length (permutations [1..5]) == P.n_permutations 5 -permutations :: (Eq a) => [a] -> [[a]] -permutations i = +-- > permutations_l [0,3] == [[0,3],[3,0]] +-- > length (permutations_l [1..5]) == P.n_permutations 5 +permutations_l :: [a] -> [[a]] +permutations_l i = let f p = P.apply_permutation p i in map f (P.permutations_n (length i)) +-- | /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 + +-- | Calculate number of permutations of a multiset. +-- +-- > 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 = P.factorial (length x) + d = product $ map P.factorial $ occ x + in n `div` d diff --git a/Music/Theory/Permutations/Morris_1984.hs b/Music/Theory/Permutations/Morris_1984.hs --- a/Music/Theory/Permutations/Morris_1984.hs +++ b/Music/Theory/Permutations/Morris_1984.hs @@ -5,32 +5,41 @@ -- module Music.Theory.Permutations.Morris_1984 where -import Data.Char {- base -} import Data.List {- base -} 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,55 +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 --- | Parse abbreviated 'Hold' notation, characters are hexedecimal. +numeric_spelling_tbl :: [(Char,Int)] +numeric_spelling_tbl = zip "1234567890ETABCDFGHJKL" [1 .. 22] + +-- | Parse abbreviated 'Hold' notation, characters are NOT hexadecimal. -- --- > to_abbrev "38A" == [3,8,10] -to_abbrev :: String -> [Int] -to_abbrev = map digitToInt +-- > 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 = @@ -99,6 +117,14 @@ else Left n : rec (m + 1) l' in rec 1 +-- | Given two sequences, derive the one-indexed "hold" list. +-- +-- > derive_holds ("12345","13254") == [1] +derive_holds :: (Eq a,Enum n,Num n) => ([a],[a]) -> [n] +derive_holds (p,q) = + let f n (i,j) = if i == j then Just n else Nothing + in catMaybes (zipWith f [1..] (zip p q)) + -- | Two-tuple to two element list. pair_to_list :: (t,t) -> [t] pair_to_list (p,q) = [p,q] @@ -113,21 +139,21 @@ -- | 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) -- | Apply abbreviated 'Hold' notation, given cardinality. -- -- > swap_abbrev 8 [3,8] [2,1,4,3,6,5,8,7] == [1,2,4,6,3,8,5,7] -swap_abbrev :: Eq a => Int -> [Int] -> [a] -> [a] +swap_abbrev :: 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'. -apply_change :: Eq a => Int -> Change -> [a] -> [a] +apply_change :: Int -> Change -> [a] -> [a] apply_change k p l = case p of Swap_All -> swap_all l @@ -139,8 +165,8 @@ -- > let r = ([1,2,4,5,3] -- > ,[[1,2,3,4,5],[2,1,3,4,5],[2,3,1,4,5],[3,2,4,1,5],[3,4,2,5,1] -- > ,[4,3,2,5,1],[4,2,3,1,5],[2,4,1,3,5],[2,1,4,3,5],[1,2,4,3,5]]) --- > in apply_method cambridgeshire_slow_course_doubles [1..5] == r -apply_method :: Eq a => Method -> [a] -> ([a],[[a]]) +-- > apply_method cambridgeshire_slow_course_doubles [1..5] == r +apply_method :: Method -> [a] -> ([a],[[a]]) apply_method m l = let k = length l f z e = (apply_change k e z,z) @@ -160,57 +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 --- | Cambridgeshire Slow Course 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. --- --- +-- | -- --- > 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 --- --- +-- | -- --- > 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 --- | 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 --- | Smithsonian Surprise Royal. --- --- +-- | -- --- > length (closed_method smithsonian_surprise_royal [1..10]) == 9 +-- > 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 = ("-3A-14-5A-16-347A-18-1456-5A-16-7A",Just "12") - in parse_method a +smithsonian_surprise_royal = parse_method smithsonian_surprise_royal_pl + +-- | +-- +-- > 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 ecumenical_surprise_maximus_pl diff --git a/Music/Theory/Pitch.hs b/Music/Theory/Pitch.hs --- a/Music/Theory/Pitch.hs +++ b/Music/Theory/Pitch.hs @@ -4,69 +4,227 @@ import Data.Char {- base -} import Data.Function {- base -} import Data.List {- base -} +import Data.Maybe {- base -} +import Text.Printf {- base -} +import qualified Text.Parsec as P {- parsec -} + import qualified Music.Theory.List as T {- hmt -} import qualified Music.Theory.Math as T {- hmt -} -import Music.Theory.Pitch.Note {- hmt -} -import Music.Theory.Pitch.Spelling {- hmt -} +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 -} --- | Pitch classes are modulo twelve integers. +-- * Octave pitch-class (generic) + +-- | 'Octave' and 'PitchClass' duple. +type Octave_PitchClass i = (i,i) + +-- | Normalise 'Octave_PitchClass' value, ie. ensure pitch-class is in (0,11). +octave_pitchclass_nrm :: (Ord i,Num i) => Octave_PitchClass i -> Octave_PitchClass i +octave_pitchclass_nrm (o,pc) = + if pc > 11 + then octave_pitchclass_nrm (o+1,pc-12) + else if pc < 0 + then octave_pitchclass_nrm (o-1,pc+12) + else (o,pc) + +-- | Transpose 'Octave_PitchClass' value. +octave_pitchclass_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i +octave_pitchclass_trs n (o,pc) = + let k = pc + n + (i,j) = k `divMod` 12 + in (o + i,j) + +-- | 'Octave_PitchClass' value to integral /midi/ note number. +-- +-- > map octave_pitchclass_to_midi [(-1,9),(8,0)] == map (+ 9) [0,99] +octave_pitchclass_to_midi :: Num i => Octave_PitchClass i -> i +octave_pitchclass_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc + +-- | Inverse of 'octave_pitchclass_to_midi'. +-- +-- > map midi_to_octave_pitchclass [0,36,60,84,91] == [(-1,0),(2,0),(4,0),(6,0),(6,7)] +midi_to_octave_pitchclass :: (Integral m,Integral i) => m -> Octave_PitchClass i +midi_to_octave_pitchclass n = (fromIntegral n - 12) `divMod` 12 + +{- | 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 (0-11) type PitchClass = Int -- | Octaves are integers, the octave of middle C is @4@. type Octave = Int -- | 'Octave' and 'PitchClass' duple. -type Octave_PitchClass i = (i,i) -type OctPC = (Octave,PitchClass) +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 (oct,pc) = (fromIntegral oct,fromIntegral pc) + +-- | Normalise 'OctPc'. +-- +-- > octpc_nrm (4,16) == (5,4) +octpc_nrm :: OctPc -> OctPc +octpc_nrm = octave_pitchclass_nrm + +-- | Transpose 'OctPc'. +-- +-- > octpc_trs 7 (4,9) == (5,4) +-- > octpc_trs (-11) (4,9) == (3,10) +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 (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 (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 = id + +-- | 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 = 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_to_octave_pitchclass + +-- * Octave & fractional pitch-class + +-- | (octave,pitch-class) to fractional octave. +-- This is an odd notation, but can be useful for writing pitch data where a float is required. +-- Note this is not a linear octave, for that see 'Sound.SC3.Common.Math.oct_to_cps'. +-- +-- > map octpc_to_foct [(4,0),(4,7),(5,11)] == [4.00,4.07,5.11] +octpc_to_foct :: (Integral i, Fractional r) => (i,i) -> r +octpc_to_foct (o,pc) = fromIntegral o + (fromIntegral pc / 100) + +-- | Inverse of 'octpc_to_foct'. +-- +-- > map foct_to_octpc [3.11,4.00,4.07,5.11] == [(3,11),(4,0),(4,7),(5,11)] +foct_to_octpc :: (Integral i, RealFrac r) => r -> (i,i) +foct_to_octpc x = + let (p,q) = T.integral_and_fractional_parts x + in (p,round (q * 100)) + +-- | 'octpc_to_midi' of 'foct_to_octpc'. +foct_to_midi :: (Integral i, RealFrac r) => r -> i +foct_to_midi = octave_pitchclass_to_midi . foct_to_octpc + +-- * FMIDI + +-- | Fractional midi note number. +type FMidi = Double + +-- | Fractional octave pitch-class (octave is integral, pitch-class is fractional). +type FOctPc = (Int,Double) + +-- | 'fromIntegral' of 'octpc_to_midi'. +octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n +octpc_to_fmidi = fromIntegral . octave_pitchclass_to_midi + +-- | Fractional midi to fractional octave pitch-class. +-- +-- > fmidi_to_foctpc 69.5 == (4,9.5) +fmidi_to_foctpc :: RealFrac f => f -> (Octave,f) +fmidi_to_foctpc n = let o = (floor n - 12) `div` 12 in (o,n - (fromIntegral (o + 1) * 12)) + +-- | Octave of fractional midi note number. +fmidi_octave :: RealFrac f => f -> Octave +fmidi_octave = fst . fmidi_to_foctpc + +foctpc_to_fmidi :: RealFrac f => (Octave,f) -> f +foctpc_to_fmidi (o,pc) = (fromIntegral (o + 1) * 12) + pc + +-- | Move fractional midi note number to indicated octave. +-- +-- > map (fmidi_in_octave 1) [59.5,60.5] == [35.5,24.5] +fmidi_in_octave :: RealFrac f => Octave -> f -> f +fmidi_in_octave o m = let (_,pc) = fmidi_to_foctpc m in foctpc_to_fmidi (o,pc) + +-- | Print fractional midi note number as ET12 pitch with cents detune in parentheses. +-- +-- > fmidi_et12_cents_pp T.pc_spell_ks 66.5 == "F♯4(+50)" +fmidi_et12_cents_pp :: Spelling PitchClass -> FMidi -> String +fmidi_et12_cents_pp sp = + let f (m,c) = + let d = T.num_diff_str (round c :: Int) + d' = if null d then "" else "(" ++ d ++ ")" + in pitch_pp (midi_to_pitch sp m) ++ d' + in f . midi_detune_normalise . fmidi_to_midi_detune + +-- * Pitch + -- | Common music notation pitch value. -data Pitch = Pitch {note :: Note_T - ,alteration :: Alteration_T +data Pitch = Pitch {note :: T.Note + ,alteration :: T.Alteration ,octave :: Octave} deriving (Eq,Show) instance Ord Pitch where compare = pitch_compare --- | Generalised pitch, given by a generalised alteration. -data Pitch' = Pitch' Note_T Alteration_T' Octave - deriving (Eq,Show) - --- | Pretty printer for 'Pitch''. -pitch'_pp :: Pitch' -> String -pitch'_pp (Pitch' n (_,a) o) = show n ++ a ++ show o - --- | 'Pitch'' printed without octave. -pitch'_class_pp :: Pitch' -> String -pitch'_class_pp = T.dropWhileRight isDigit . pitch'_pp - -- | Simplify 'Pitch' to standard 12ET by deleting quarter tones. -- --- > let p = Pitch A QuarterToneSharp 4 --- > in alteration (pitch_clear_quarter_tone p) == Sharp +-- > let p = Pitch T.A T.QuarterToneSharp 4 +-- > alteration (pitch_clear_quarter_tone p) == T.Sharp pitch_clear_quarter_tone :: Pitch -> Pitch pitch_clear_quarter_tone p = let Pitch n a o = p - in Pitch n (alteration_clear_quarter_tone a) o + in Pitch n (T.alteration_clear_quarter_tone a) o -- | 'Pitch' to 'Octave' and 'PitchClass' notation. -- -- > pitch_to_octpc (Pitch F Sharp 4) == (4,6) pitch_to_octpc :: Integral i => Pitch -> Octave_PitchClass i -pitch_to_octpc = midi_to_octpc . pitch_to_midi +pitch_to_octpc = midi_to_octave_pitchclass . T.int_id . pitch_to_midi -- | Is 'Pitch' 12-ET. pitch_is_12et :: Pitch -> Bool -pitch_is_12et = alteration_is_12et . alteration +pitch_is_12et = T.alteration_is_12et . alteration -- | 'Pitch' to midi note number notation. -- -- > pitch_to_midi (Pitch A Natural 4) == 69 pitch_to_midi :: Integral i => Pitch -> i pitch_to_midi (Pitch n a o) = - let a' = alteration_to_diff_err a - n' = note_to_pc n + let a' = T.alteration_to_diff_err a + n' = T.note_to_pc n o' = fromIntegral o in 12 + o' * 12 + n' + a' @@ -75,17 +233,17 @@ -- > pitch_to_fmidi (Pitch A QuarterToneSharp 4) == 69.5 pitch_to_fmidi :: Fractional n => Pitch -> n pitch_to_fmidi (Pitch n a o) = - let a' = alteration_to_fdiff a + let a' = T.alteration_to_fdiff a o' = fromIntegral o - n' = fromInteger (note_to_pc n) + n' = fromInteger (T.note_to_pc n) in 12 + o' * 12 + n' + a' -- | Extract 'PitchClass' of 'Pitch' -- --- > pitch_to_pc (Pitch A Natural 4) == 9 --- > pitch_to_pc (Pitch F Sharp 4) == 6 +-- > map pitch_to_pc [Pitch A Natural 4,Pitch F Sharp 4] == [9,6] +-- > map pitch_to_pc [Pitch C Flat 4,Pitch B Sharp 5] == [11,0] pitch_to_pc :: Pitch -> PitchClass -pitch_to_pc (Pitch n a _) = note_to_pc n + alteration_to_diff_err a +pitch_to_pc (Pitch n a _) = (T.note_to_pc n + T.alteration_to_diff_err a) `mod` 12 -- | 'Pitch' comparison, implemented via 'pitch_to_fmidi'. -- @@ -95,110 +253,142 @@ let f = pitch_to_fmidi :: Pitch -> Double in compare `on` f --- | Given 'Spelling' function translate from 'OctPC' notation to --- 'Pitch'. +-- * Spelling + +-- | Function to spell a 'PitchClass'. +type Spelling n = n -> (T.Note,T.Alteration) + +-- | Variant of 'Spelling' for incomplete functions. +type Spelling_M i = i -> Maybe (T.Note,T.Alteration) + +-- | 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 octpc_to_pitch sp (o,pc) = let (n,a) = sp pc in Pitch n a (fromIntegral o) --- | Normalise 'OctPC' value, ie. ensure 'PitchClass' is in (0,11). +-- | Midi note number to 'Pitch'. -- --- > octpc_nrm (4,16) == (5,4) -octpc_nrm :: Integral i => Octave_PitchClass i -> Octave_PitchClass i -octpc_nrm (o,pc) = - if pc > 11 - then octpc_nrm (o+1,pc-12) - else if pc < 0 - then octpc_nrm (o-1,pc+12) - else (o,pc) +-- > import Music.Theory.Pitch.Spelling.Table as T +-- > let r = ["C4","E♭4","F♯4"] +-- > map (pitch_pp . midi_to_pitch T.pc_spell_ks) [60,63,66] == r +midi_to_pitch :: (Integral i,Integral k) => Spelling k -> i -> Pitch +midi_to_pitch sp = octpc_to_pitch sp . midi_to_octave_pitchclass --- | Transpose 'OctPC' value. +{- | 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 + (Pitch n a o) = midi_to_pitch sp m' + q = m - fromIntegral m' + in case T.alteration_edit_quarter_tone q a of + Nothing -> Nothing + Just a' -> Just (Pitch n a' o) + +-- | Erroring variant. -- --- > octpc_trs 7 (4,9) == (5,4) --- > octpc_trs (-11) (4,9) == (3,10) -octpc_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i -octpc_trs n (o,pc) = - let pc' = fromIntegral pc - k = pc' + n - (i,j) = k `divMod` 12 - in (fromIntegral o + fromIntegral i,fromIntegral j) +-- > import Music.Theory.Pitch.Spelling as T +-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 65.5) == "F𝄲4" +-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 66.5) == "F𝄰4" +-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 67.5) == "A𝄭4" +-- > pitch_pp (fmidi_to_pitch_err T.pc_spell_ks 69.5) == "B𝄭4" +fmidi_to_pitch_err :: (Show n,RealFrac n) => Spelling Int -> n -> Pitch +fmidi_to_pitch_err sp m = fromMaybe (error (show ("fmidi_to_pitch",m))) (fmidi_to_pitch sp m) --- | 'OctPC' value to integral /midi/ note number. +-- | Composition of 'pitch_to_fmidi' and then 'fmidi_to_pitch'. -- --- > octpc_to_midi (4,9) == 69 -octpc_to_midi :: Integral i => Octave_PitchClass i -> i -octpc_to_midi (o,pc) = 60 + ((fromIntegral o - 4) * 12) + pc +-- > import Music.Theory.Pitch.Name as T +-- > import Music.Theory.Pitch.Spelling as T +-- > 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) --- | 'fromIntegral' of 'octpc_to_midi'. -octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n -octpc_to_fmidi = fromIntegral . octpc_to_midi +-- | Displacement of /q/ into octave of /p/. +fmidi_in_octave_of :: RealFrac f => f -> f -> f +fmidi_in_octave_of p = fmidi_in_octave (fmidi_octave p) --- | Inverse of 'octpc_to_midi'. +-- | Octave displacement of /m2/ that is nearest /m1/. -- --- > midi_to_octpc 69 == (4,9) -midi_to_octpc :: Integral i => i -> Octave_PitchClass i -midi_to_octpc n = (n - 12) `divMod` 12 +-- > let p = octpc_to_fmidi (2,1) +-- > let q = map octpc_to_fmidi [(4,11),(4,0),(4,1)] +-- > map (fmidi_in_octave_nearest p) q == [35,36,37] +fmidi_in_octave_nearest :: RealFrac n => n -> n -> n +fmidi_in_octave_nearest m1 m2 = + let m2' = fmidi_in_octave (fmidi_octave m1) m2 + m2'' = [m2' - 12,m2',m2' + 12] + d = map (abs . (m1 -)) m2'' + z = sortOn snd (zip m2'' d) + in fst (head z) --- | Enumerate range, inclusive. +-- | Displacement of /q/ into octave above /p/. -- --- > octpc_range ((3,8),(4,1)) == [(3,8),(3,9),(3,10),(3,11),(4,0),(4,1)] -octpc_range :: (OctPC,OctPC) -> [OctPC] -octpc_range (l,r) = - let (l',r') = (octpc_to_midi l,octpc_to_midi r) - in map midi_to_octpc [l' .. r'] +-- > fmidi_in_octave_of 69 51 == 63 +-- > fmidi_in_octave_nearest 69 51 == 63 +-- > fmidi_in_octave_above 69 51 == 75 +fmidi_in_octave_above :: RealFrac a => a -> a -> a +fmidi_in_octave_above p q = let r = fmidi_in_octave_nearest p q in if r < p then r + 12 else r --- | Midi note number to 'Pitch'. +-- | Displacement of /q/ into octave below /p/. -- --- > let r = ["C4","E♭4","F♯4"] --- > in map (pitch_pp . midi_to_pitch pc_spell_ks) [60,63,66] == r -midi_to_pitch :: Integral i => Spelling i -> i -> Pitch -midi_to_pitch sp = octpc_to_pitch sp . midi_to_octpc +-- > fmidi_in_octave_of 69 85 == 61 +-- > fmidi_in_octave_nearest 69 85 == 73 +-- > fmidi_in_octave_below 69 85 == 61 +fmidi_in_octave_below :: RealFrac a => a -> a -> a +fmidi_in_octave_below p q = let r = fmidi_in_octave_nearest p q in if r > p then r - 12 else r --- | Fractional midi note number to 'Pitch'. +-- | CPS form of binary /fmidi/ function /f/. +lift_fmidi_binop_to_cps :: Floating f => (f -> f -> f) -> f -> f -> f +lift_fmidi_binop_to_cps f p = T.fmidi_to_cps . f (cps_to_fmidi p) . cps_to_fmidi + +-- | CPS form of 'fmidi_in_octave_nearest'. -- --- > import Music.Theory.Pitch.Spelling --- > pitch_pp (fmidi_to_pitch pc_spell_ks 65.5) == "F𝄲4" --- > pitch_pp (fmidi_to_pitch pc_spell_ks 66.5) == "F𝄰4" --- > pitch_pp (fmidi_to_pitch pc_spell_ks 67.5) == "A𝄭4" --- > pitch_pp (fmidi_to_pitch pc_spell_ks 69.5) == "B𝄭4" -fmidi_to_pitch :: RealFrac n => Spelling Int -> n -> Pitch -fmidi_to_pitch sp m = - let m' = round m - (Pitch n a o) = midi_to_pitch sp m' - q = m - fromIntegral m' - in case alteration_edit_quarter_tone q a of - Nothing -> error "fmidi_to_pitch" - Just a' -> Pitch n a' o +-- > map cps_octave [440,256] == [4,4] +-- > round (cps_in_octave_nearest 440 256) == 512 +cps_in_octave_nearest :: (Floating f,RealFrac f) => f -> f -> f +cps_in_octave_nearest = lift_fmidi_binop_to_cps fmidi_in_octave_nearest --- | Composition of 'pitch_to_fmidi' and then 'fmidi_to_pitch'. +-- | CPS form of 'fmidi_in_octave_above'. -- --- > import Music.Theory.Pitch.Name as T --- > import Music.Theory.Pitch.Spelling as T +-- > cps_in_octave_above 55.0 392.0 == 97.99999999999999 +cps_in_octave_above :: (Floating f,RealFrac f) => f -> f -> f +cps_in_octave_above = lift_fmidi_binop_to_cps fmidi_in_octave_above + +-- | CPS form of 'fmidi_in_octave_above'. +cps_in_octave_below :: (Floating f,RealFrac f) => f -> f -> f +cps_in_octave_below = lift_fmidi_binop_to_cps fmidi_in_octave_below + +-- | Direct implementation of 'cps_in_octave_above'. +-- Raise or lower the frequency /q/ by octaves until it is in the +-- octave starting at /p/. -- --- > pitch_tranpose T.pc_spell_ks 2 T.ees5 == T.f5 -pitch_tranpose :: RealFrac n => Spelling Int -> n -> Pitch -> Pitch -pitch_tranpose sp n p = - let m = pitch_to_fmidi p - in fmidi_to_pitch sp (m + n) +-- > cps_in_octave_above_direct 55.0 392.0 == 98.0 +cps_in_octave_above_direct :: (Ord a, Fractional a) => a -> a -> a +cps_in_octave_above_direct p q = + let f = cps_in_octave_above_direct p + in if q > p * 2 then f (q / 2) else if q < p then f (q * 2) else q -- | Set octave of /p2/ so that it nearest to /p1/. -- +-- > import Music.Theory.Pitch -- > import Music.Theory.Pitch.Name as T --- --- > let {r = ["B1","C2","C#2"];f = pitch_in_octave_nearest T.cis2} --- > in map (pitch_pp_iso . f) [T.b4,T.c4,T.cis4] == r +-- > let r = ["B1","C2","C#2"] +-- > let f = pitch_in_octave_nearest T.cis2 +-- > map (pitch_pp_iso . f) [T.b4,T.c4,T.cis4] == r pitch_in_octave_nearest :: Pitch -> Pitch -> Pitch pitch_in_octave_nearest p1 p2 = - let o1 = octave p1 - p2' = map (\n -> p2 {octave = n}) [o1 - 1,o1,o1 + 1] - m1 = pitch_to_fmidi p1 :: Double - m2 = map (pitch_to_fmidi) p2' - d = map (abs . (m1 -)) m2 - z = sortBy (compare `on` snd) (zip p2' d) - in fst (head z) + let f = pitch_to_fmidi :: Pitch -> Double + 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 @@ -207,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 @@ -219,145 +409,327 @@ -- | Rewrite 'Pitch' to not use @3/4@ tone alterations, ie. re-spell -- to @1/4@ alteration. -- --- > let {p = Pitch A ThreeQuarterToneFlat 4 --- > ;q = Pitch G QuarterToneSharp 4} --- > in pitch_rewrite_threequarter_alteration p == q +-- > let p = Pitch T.A T.ThreeQuarterToneFlat 4 +-- > let q = Pitch T.G T.QuarterToneSharp 4 +-- > pitch_rewrite_threequarter_alteration p == q pitch_rewrite_threequarter_alteration :: Pitch -> Pitch pitch_rewrite_threequarter_alteration (Pitch n a o) = case a of - ThreeQuarterToneFlat -> pitch_note_lower (Pitch n QuarterToneSharp o) - ThreeQuarterToneSharp -> pitch_note_raise (Pitch n QuarterToneFlat o) + T.ThreeQuarterToneFlat -> pitch_note_lower (Pitch n T.QuarterToneSharp o) + T.ThreeQuarterToneSharp -> pitch_note_raise (Pitch n T.QuarterToneFlat o) _ -> Pitch n a o -- | Apply function to 'octave' of 'PitchClass'. -- --- > pitch_edit_octave (+ 1) (Pitch A Natural 4) == Pitch A Natural 5 +-- > pitch_edit_octave (+ 1) (Pitch T.A T.Natural 4) == Pitch T.A T.Natural 5 pitch_edit_octave :: (Octave -> Octave) -> Pitch -> Pitch pitch_edit_octave f (Pitch n a o) = Pitch n a (f o) -- * Frequency (CPS) --- | /Midi/ note number to cycles per second. --- --- > map midi_to_cps [60,69] == [261.6255653005986,440.0] -midi_to_cps :: (Integral i,Floating f) => i -> f -midi_to_cps = fmidi_to_cps . fromIntegral +-- | '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 --- | Fractional /midi/ note number to cycles per second. --- --- > map fmidi_to_cps [69,69.1] == [440.0,442.5488940698553] -fmidi_to_cps :: Floating a => a -> a -fmidi_to_cps i = 440 * (2 ** ((i - 69) * (1 / 12))) +-- | '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 = pitch_to_cps_k0 (69,f0) --- | 'fmidi_to_cps' of 'pitch_to_fmidi'. +-- | 'pitch_to_cps_k0' (60,440). pitch_to_cps :: Floating n => Pitch -> n -pitch_to_cps = fmidi_to_cps . pitch_to_fmidi +pitch_to_cps = pitch_to_cps_k0 (69,440) --- | Frequency (cycles per second) to /midi/ note number, ie. 'round' --- of 'cps_to_fmidi'. +-- | Frequency (cps = cycles per second) to fractional /midi/ note +-- number, given frequency of ISO A4 (mnn = 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_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_k0 (69,440) + +-- | Frequency (cycles per second) to /midi/ note number, +-- ie. 'round' of 'cps_to_fmidi'. +-- -- > map cps_to_midi [261.6,440] == [60,69] cps_to_midi :: (Integral i,Floating f,RealFrac f) => f -> i cps_to_midi = round . cps_to_fmidi --- | Frequency (cycles per second) to fractional /midi/ note number. +-- | '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_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_k0 (69,440) + +-- | 'midi_to_octpc' of 'cps_to_midi'. +cps_to_octpc :: (Floating f,RealFrac f,Integral i) => f -> Octave_PitchClass i +cps_to_octpc = midi_to_octave_pitchclass . T.real_round_int . cps_to_fmidi + +cps_octave :: (Floating f,RealFrac f) => f -> Octave +cps_octave = fst . cps_to_octpc + +-- * MIDI detune (cents) + +-- | Is cents in (-50,+50]. -- --- > 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 a = (logBase 2 (a * (1 / 440)) * 12) + 69 +-- > map cents_is_normal [-250,-75,75,250] == replicate 4 False +cents_is_normal :: (Num c, Ord c) => c -> Bool +cents_is_normal c = c > (-50) && c <= 50 --- | Midi note number with cents detune. -type Midi_Detune = (Int,Double) +-- | 'cents_is_normal' of 'snd'. +midi_detune_is_normal :: (Num c, Ord c) => (x,c) -> Bool +midi_detune_is_normal = cents_is_normal . snd +-- | In normal form the detune is in the range (-50,+50] instead of [0,100) or wider. +-- +-- > map midi_detune_normalise [(60,-250),(60,-75),(60,75),(60,250)] +midi_detune_normalise :: (Num m,Ord c,Num c) => (m,c) -> (m,c) +midi_detune_normalise = + let recur (m,c) = + if c > 50 + then recur (m + 1,c - 100) + else if c > (-50) + then (m,c) + else recur (m - 1,c + 100) + in recur + +-- | In normal-positive form the detune is in the range (0,+100]. +-- +-- > map midi_detune_normalise_positive [(60,-250),(60,-75),(60,75),(60,250)] +midi_detune_normalise_positive :: (Num m,Ord m,Ord c,Num c) => (m,c) -> (m,c) +midi_detune_normalise_positive = + let recur (m,c) = + if c < 0 + then recur (m - 1,c + 100) + else if c > 100 + then recur (m + 1,c - 100) + else (m,c) + in recur + +-- | Inverse of 'cps_to_midi_detune', given frequency of ISO @A4@. +midi_detune_to_cps_f0 :: (Integral m,Real c) => Double -> (m,c) -> Double +midi_detune_to_cps_f0 f0 (m,c) = T.fmidi_to_cps_f0 f0 (fromIntegral m + (realToFrac c / 100)) + +-- | Inverse of 'cps_to_midi_detune'. +-- +-- > map midi_detune_to_cps [(69,0),(68,100)] == [440,440] +midi_detune_to_cps :: (Integral m,Real c) => (m,c) -> Double +midi_detune_to_cps = midi_detune_to_cps_f0 440 + +-- | 'Midi_Detune' to fractional midi note number. +-- +-- > midi_detune_to_fmidi (60,50.0) == 60.50 +midi_detune_to_fmidi :: (Integral m,Real c) => (m,c) -> Double +midi_detune_to_fmidi (mnn,c) = fromIntegral mnn + (realToFrac c / 100) + +-- | 'Midi_Detune' to 'Pitch', detune must be precisely at a notateable Pitch. +-- +-- > let p = Pitch {note = T.C, alteration = T.QuarterToneSharp, octave = 4} +-- > midi_detune_to_pitch T.pc_spell_ks (midi_detune_nearest_24et (60,35)) == p +midi_detune_to_pitch :: (Integral m,Real c) => Spelling Int -> (m,c) -> Pitch +midi_detune_to_pitch sp = fmidi_to_pitch_err sp . cps_to_fmidi . midi_detune_to_cps + +-- | Midi note number with real-valued cents detune. +type Midi_Detune = (Midi,Double) + +-- | Fractional midi note number to 'Midi_Detune'. +-- +-- > fmidi_to_midi_detune 60.50 == (60,50.0) +fmidi_to_midi_detune :: Double -> Midi_Detune +fmidi_to_midi_detune mnn = + let (n,c) = T.integral_and_fractional_parts mnn + in (n,c * 100) + -- | Frequency (in hertz) to 'Midi_Detune'. -- -- > map (fmap round . cps_to_midi_detune) [440.00,508.35] == [(69,0),(71,50)] cps_to_midi_detune :: Double -> Midi_Detune -cps_to_midi_detune f = - let (n,c) = T.integral_and_fractional_parts (cps_to_fmidi f) - in (n,c * 100) +cps_to_midi_detune = fmidi_to_midi_detune . cps_to_fmidi --- | Inverse of 'cps_to_midi_detune'. -midi_detune_to_cps :: Midi_Detune -> Double -midi_detune_to_cps (m,c) = fmidi_to_cps (fromIntegral m + (c / 100)) +-- | Round /detune/ value to nearest multiple of @50@, normalised. +-- +-- > map midi_detune_nearest_24et [(59,70),(59,80)] == [(59,50),(60,00)] +midi_detune_nearest_24et :: Midi_Detune -> Midi_Detune +midi_detune_nearest_24et (m,dt) = midi_detune_normalise (m,T.round_to 50 dt) --- | 'midi_to_cps' of 'octpc_to_midi'. +-- * MIDI cents + +-- | Midi note number with integral cents detune. +type Midi_Cents = (Midi,Int) + +midi_detune_to_midi_cents :: Midi_Detune -> Midi_Cents +midi_detune_to_midi_cents (m,c) = (m,round c) + +-- | Printed as /fmidi/ value with cents to two places. Must be normal. -- --- > octpc_to_cps (4,9) == 440 -octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n -octpc_to_cps = midi_to_cps . octpc_to_midi +-- > map midi_cents_pp [(60,0),(60,25)] == ["60.00","60.25"] +midi_cents_pp :: Midi_Cents -> String +midi_cents_pp (m,c) = if cents_is_normal c then printf "%d.%02d" m c else error "midi_cents_pp" --- | 'midi_to_octpc' of 'cps_to_midi'. -cps_to_octpc :: (Floating f,RealFrac f,Integral i) => f -> Octave_PitchClass i -cps_to_octpc = midi_to_octpc . cps_to_midi +-- * 24ET +{- | The 24ET pitch-class universe, with /sharp/ spellings, in octave '4'. + +> length pc24et_univ == 24 + +> let r = "C C𝄲 C♯ C𝄰 D D𝄲 D♯ D𝄰 E E𝄲 F F𝄲 F♯ F𝄰 G G𝄲 G♯ G𝄰 A A𝄲 A♯ A𝄰 B B𝄲" +> unwords (map pitch_class_pp pc24et_univ) == r + +-} +pc24et_univ :: [Pitch] +pc24et_univ = + let a = [T.Natural,T.QuarterToneSharp,T.Sharp,T.ThreeQuarterToneSharp] + f (n,k) = map (\i -> Pitch n (a !! i) 4) [0 .. k - 1] + in concatMap f (zip T.note_seq [4,4,2,4,4,4,2]) + +-- | 'genericIndex' into 'pc24et_univ'. +-- +-- > pitch_class_pp (pc24et_to_pitch 13) == "F𝄰" +pc24et_to_pitch :: Integral i => i -> Pitch +pc24et_to_pitch = genericIndex pc24et_univ + +-- * Pitch, rational alteration. + +-- | Generalised pitch, given by a generalised alteration. +data Pitch_R = Pitch_R T.Note T.Alteration_R Octave + deriving (Eq,Show) + +-- | Pretty printer for 'Pitch_R'. +pitch_r_pp :: Pitch_R -> String +pitch_r_pp (Pitch_R n (_,a) o) = show n ++ a ++ show o + +-- | 'Pitch_R' printed without octave. +pitch_r_class_pp :: Pitch_R -> String +pitch_r_class_pp = T.dropWhileRight isDigit . pitch_r_pp + -- * Parsers --- | Slight generalisation of ISO pitch representation. Allows octave +-- | 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"] == [2,4,2,1]x +parse_octave :: Octave -> String -> Octave +parse_octave def_o = T.run_parser_error (p_octave_iso_opt def_o) + +-- | Generalisation of ISO pitch representation. Allows octave -- to be elided, pitch names to be lower case, and double sharps -- written as @##@. -- -- See -- --- > let r = [Pitch C Natural 4,Pitch A Flat 5,Pitch F DoubleSharp 6] --- > in mapMaybe (parse_iso_pitch_oct 4) ["C","Ab5","f##6",""] == r +-- > 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 nte n = let tb = zip "cdefgab" [C,D,E,F,G,A,B] - in lookup (toLower n) tb - oct o = case o of - [] -> Just def_o - [n] -> if isDigit n - then Just (fromIntegral (digitToInt n)) - else Nothing - _ -> Nothing - mk n a o = case nte n of - Nothing -> Nothing - Just n' -> fmap (Pitch n' a) (oct o) - in case s of - [] -> Nothing - n:'b':'b':o -> mk n DoubleFlat o - n:'#':'#':o -> mk n DoubleSharp o - n:'x':o -> mk n DoubleSharp o - n:'b':o -> mk n Flat o - n:'#':o -> mk n Sharp o - n:o -> mk n Natural o +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 parse_iso_pitch = parse_iso_pitch_oct (error "parse_iso_pitch: no octave") +-- | 'error' variant. +parse_iso_pitch_err :: String -> Pitch +parse_iso_pitch_err = fromMaybe (error "parse_iso_pitch") . parse_iso_pitch + -- * Pretty printers -- | Pretty printer for 'Pitch' (unicode, see 'alteration_symbol'). +-- Option selects if 'Natural's are printed. -- --- > pitch_pp (Pitch E Flat 4) == "E♭4" --- > pitch_pp (Pitch F QuarterToneSharp 3) == "F𝄲3" +-- > pitch_pp_opt (True,True) (Pitch T.E T.Natural 4) == "E♮4" +pitch_pp_opt :: (Bool,Bool) -> Pitch -> String +pitch_pp_opt (show_nat,show_oct) (Pitch n a o) = + let a' = if a == T.Natural && not show_nat then "" else [T.alteration_symbol a] + rem_oct_f c = isDigit c || c == '-' -- negative octave values... + rem_oct = if show_oct then id else T.dropWhileRight rem_oct_f + in rem_oct (show n ++ a' ++ show o) + +-- | 'pitch_pp_opt' with default options, ie. (False,True). +-- +-- > pitch_pp (Pitch T.E T.Natural 4) == "E4" +-- > pitch_pp (Pitch T.E T.Flat 4) == "E♭4" +-- > pitch_pp (Pitch T.F T.QuarterToneSharp 3) == "F𝄲3" pitch_pp :: Pitch -> String -pitch_pp (Pitch n a o) = - let a' = if a == Natural then "" else [alteration_symbol a] - in show n ++ a' ++ show o +pitch_pp = pitch_pp_opt (False,True) --- | 'Pitch' printed without octave. +-- | 'pitch_pp_opt' with options (False,False). +-- +-- > pitch_class_pp (Pitch T.C T.ThreeQuarterToneSharp 0) == "C𝄰" pitch_class_pp :: Pitch -> String -pitch_class_pp = T.dropWhileRight isDigit . pitch_pp +pitch_class_pp = pitch_pp_opt (False,False) -- | Sequential list of /n/ pitch class names starting from /k/. -- --- > pitch_class_names_12et 11 2 == ["B","C"] -pitch_class_names_12et :: Integral n => n -> n -> [String] -pitch_class_names_12et k n = - let f = pitch_class_pp . midi_to_pitch pc_spell_ks +-- > import Music.Theory.Pitch.Spelling.Table +-- > unwords (pitch_class_names_12et pc_spell_ks 0 12) == "C C♯ D E♭ E F F♯ G A♭ A B♭ B" +-- > pitch_class_names_12et pc_spell_ks 11 2 == ["B","C"] +pitch_class_names_12et :: Integral n => Spelling n -> n -> n -> [String] +pitch_class_names_12et sp k n = + let f = pitch_class_pp . midi_to_pitch sp . T.from_integral_to_int in map f [60 + k .. 60 + k + n - 1] -- | Pretty printer for 'Pitch' (ISO, ASCII, see 'alteration_iso'). -- -- > pitch_pp_iso (Pitch E Flat 4) == "Eb4" -- > pitch_pp_iso (Pitch F DoubleSharp 3) == "Fx3" +-- > pitch_pp_iso (Pitch C ThreeQuarterToneSharp 4) -- error pitch_pp_iso :: Pitch -> String -pitch_pp_iso (Pitch n a o) = show n ++ alteration_iso a ++ show o +pitch_pp_iso (Pitch n a o) = show n ++ T.alteration_iso a ++ show o +-- | Lilypond octave syntax. +ly_octave_tbl :: [(Octave, String)] +ly_octave_tbl = + [(-1,",,,,") + ,( 0,",,,") + ,( 1,",,") + ,( 2,",") + ,( 3,"") + ,( 4,"'") + ,( 5,"''") + ,( 6,"'''") + ,( 7,"''''") + ,( 8,"'''''")] + +-- | Lookup 'ly_octave_tbl'. +octave_pp_ly :: Octave -> String +octave_pp_ly o = T.lookup_err o ly_octave_tbl + +-- | Parse lilypond octave indicator. +octave_parse_ly :: String -> Maybe Octave +octave_parse_ly s = T.reverse_lookup s ly_octave_tbl + -- | Pretty printer for 'Pitch' (ASCII, see 'alteration_tonh'). -- -- > pitch_pp_hly (Pitch E Flat 4) == "ees4" @@ -366,7 +738,7 @@ pitch_pp_hly :: Pitch -> String pitch_pp_hly (Pitch n a o) = let n' = map toLower (show n) - in n' ++ alteration_tonh a ++ show o + in n' ++ T.alteration_tonh a ++ show o -- | Pretty printer for 'Pitch' (Tonhöhe, see 'alteration_tonh'). -- @@ -377,9 +749,41 @@ pitch_pp_tonh (Pitch n a o) = let o' = show o in case (n,a) of - (B,Natural) -> "H" ++ o' - (B,Flat) -> "B" ++ o' - (B,DoubleFlat) -> "Heses" ++ o' - (A,Flat) -> "As" ++ o' - (E,Flat) -> "Es" ++ o' - _ -> show n ++ alteration_tonh a ++ o' + (T.B,T.Natural) -> "H" ++ o' + (T.B,T.Flat) -> "B" ++ o' + (T.B,T.DoubleFlat) -> "Heses" ++ o' + (T.A,T.Flat) -> "As" ++ o' + (T.E,T.Flat) -> "Es" ++ o' + _ -> show n ++ T.alteration_tonh a ++ o' + +-- * Parsers + +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 :: T.P Pitch +p_pitch_ly = do + (n,a) <- T.p_note_alteration_ly + o <- P.optionMaybe p_octave_ly + return (Pitch n (fromMaybe T.Natural a) (fromMaybe 3 o)) + +-- | Run 'p_pitch_ly'. +-- +-- > 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 = T.run_parser_error p_pitch_ly + +-- | Parser for hly notation. +p_pitch_hly :: T.P Pitch +p_pitch_hly = do + (n,a) <- T.p_note_alteration_ly + 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 = T.run_parser_error p_pitch_hly diff --git a/Music/Theory/Pitch/Bark.hs b/Music/Theory/Pitch/Bark.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Bark.hs @@ -0,0 +1,69 @@ +-- | Zwicker, E. (1961) "Subdivision of the audible frequency range into critical bands" +-- The Journal of the Acoustical Society of America, Volume 33, Issue 2, p. 248 (1961) +-- +-- +module Music.Theory.Pitch.Bark where + +-- * TABLES + +-- | Center freqencies of Bark scale critical bands (hz). +bark_center :: Num n => [n] +bark_center = + [50,150,250,350,450,570,700,840,1000,1170 + ,1370,1600,1850,2150,2500,2900,3400,4000,4800,5800 + ,7000,8500,10500,13500] + +-- | Edge freqencies of Bark scale critical bands (hz). +bark_edge :: Num n => [n] +bark_edge = + [0,100,200,300,400,510,630,770,920,1080,1270 + ,1480,1720,2000,2320,2700,3150,3700,4400,5300,6400 + ,7700,9500,12000,15500] + +-- | Bandwidths of Bark scale critical bands (hz). +bark_bandwidth :: Num n => [n] +bark_bandwidth = let c = bark_edge in zipWith (-) (tail c) c + +-- * FUNCTIONS + +-- | Zwicker & Terhardt (1980) +-- +-- > map (round . cps_to_bark_zwicker) bark_centre == concat [[0..7],[9..15],[15..19],[21..24]] +-- > let f = [0,100 .. 8000] in Sound.SC3.Plot.plot_p2_ln [zip f (map cps_to_bark_zwicker f)] +cps_to_bark_zwicker :: Floating a => a -> a +cps_to_bark_zwicker x = 13 * atan (0.00076 * x) + 3.5 * atan ((x / 7500) ** 2) + +-- | Traunmüller, Hartmut. +-- "Analytical Expressions for the Tonotopic Sensory Scale." +-- Journal of the Acoustical Society of America. Vol. 88, Issue 1, 1990, pp. 97-100. +-- +-- > r = concat [[0,1],[3,4],[4],[6..9],[9,10],[12],[12..17],[19,20],[20..23]] +-- > map (round . cps_to_bark_traunmuller) bark_centre == r +-- > let f = [0,100 .. 8000] in Sound.SC3.Plot.plot_p2_ln [zip f (map cps_to_bark_traunmuller f)] +cps_to_bark_traunmuller :: (Fractional n,Ord n) => n -> n +cps_to_bark_traunmuller x = + let y = ((26.81 * x) / (1960 + x)) - 0.53 + in if y < 2 then y + 0.15 * (2 - y) else if y > 20.1 then y + 0.22 * (y - 20.1) else y + +-- | Traunmüller (1990) +-- +-- > Sound.SC3.Plot.plot_p2_ln [zip (map bark_to_cps_traunmuller [0..23]) [0..23]] +bark_to_cps_traunmuller :: (Fractional n,Ord n) => n -> n +bark_to_cps_traunmuller y = + let f x = 1960 * ((x + 0.53) / (26.28 - x)) + in if y < 2 then f ((y - 0.3) / 0.85) else if y > 20.1 then f ((y + 4.422) / 1.22) else f y + +-- | Wang, Sekey & Gersho (1992) +-- +-- > map (round . cps_to_bark_wsg) bark_centre == concat [[0..9],[9..21],[23]] +-- > let f = [0,100 .. 8000] in Sound.SC3.Plot.plot_p2_ln [zip f (map cps_to_bark_wsg f)] +cps_to_bark_wsg :: Floating a => a -> a +cps_to_bark_wsg x = 6 * asinh (x / 600) + +-- | Wang, Sekey & Gersho (1992) +-- +-- > r = [100,204,313,430,560,705,870,1059,1278,1532,1828,2176,2584,3065,3630,4297,5083,6011,7106,8399] +-- > map (round . bark_to_cps_wsg) [1 .. 20] == r +-- > Sound.SC3.Plot.plot_p2_ln [zip (map bark_to_cps_wsg [0..23]) [0..23]] +bark_to_cps_wsg :: Floating a => a -> a +bark_to_cps_wsg x = 600 * sinh (x / 6) diff --git a/Music/Theory/Pitch/Chord.hs b/Music/Theory/Pitch/Chord.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Chord.hs @@ -0,0 +1,148 @@ +module Music.Theory.Pitch.Chord where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Text.Parsec 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.Alteration) + +pc_pp :: Pc -> [Char] +pc_pp (n,a) = T.note_pp n : T.alteration_iso a + +-- | D = dominant, M = major +data Extension = D7 | M7 deriving (Eq,Show) + +extension_tbl :: Num n => [(Extension, (String,n))] +extension_tbl = [(D7,("7",10)),(M7,("M7",11))] + +extension_dat :: Num n => Extension -> (String,n) +extension_dat = flip T.lookup_err extension_tbl + +extension_pp :: Extension -> String +extension_pp = fst . (extension_dat :: Extension -> (String,Int)) + +extension_to_pc :: Num n => Extension -> n +extension_to_pc = snd . extension_dat + +data Chord_Type = Major | Minor + | Augmented | Diminished + | Diminished_7 | Half_Diminished + | Suspended_2 | Suspended_4 + deriving (Eq,Show) + +is_suspended :: Chord_Type -> Bool +is_suspended ty = ty `elem` [Suspended_2,Suspended_4] + +-- | Names and pc-sets for chord types. +-- The name used here is in the first position, alternates follow. +chord_type_tbl :: Num n => [(Chord_Type,([String],[n]))] +chord_type_tbl = + [(Major,(["","M","maj"],[0,4,7])) + ,(Minor,(["m","min"],[0,3,7])) + ,(Augmented,(["+","aug"],[0,4,8])) + ,(Diminished,(["o","dim"],[0,3,6])) + ,(Diminished_7,(["o7","dim7"],[0,3,6,9])) + ,(Half_Diminished,(["Ø","halfdim","m7(b5)"],[0,3,6,10])) + ,(Suspended_2,(["sus2"],[0,2,7])) + ,(Suspended_4,(["sus4"],[0,5,7]))] + +chord_type_dat :: Num n => Chord_Type -> ([String],[n]) +chord_type_dat = flip T.lookup_err chord_type_tbl + +chord_type_pp :: Chord_Type -> String +chord_type_pp = head . fst . (chord_type_dat :: Chord_Type -> ([String],[Int])) + +chord_type_pcset :: Num n => Chord_Type -> [n] +chord_type_pcset = snd . chord_type_dat + +-- (root,mode,extensions,bass) +data Chord = Chord Pc Chord_Type (Maybe Extension) (Maybe Pc) + deriving (Show) + +chord_pcset :: Chord -> (Maybe Int,[Int]) +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 (`delete` ch) bs' + in (bs',ch') + +bass_pp :: Pc -> String +bass_pp = ('/' :) . pc_pp + +chord_pp :: Chord -> String +chord_pp (Chord pc ty ex bs) = + let (pre_ty,post_ty) = if is_suspended ty + then (Nothing,Just ty) + else (Just ty,Nothing) + in concat [pc_pp pc + ,maybe "" chord_type_pp pre_ty + ,maybe "" extension_pp ex + ,maybe "" chord_type_pp post_ty + ,maybe "" bass_pp bs] + +m_error :: String -> Maybe a -> a +m_error txt = fromMaybe (error txt) + +p_pc :: T.P Pc +p_pc = do + n <- T.p_note_t + a <- P.optionMaybe (T.p_alteration_t_iso True) + return (n,fromMaybe T.Natural a) + +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 :: T.P Chord_Type +p_chord_type = + let m = P.char 'm' >> return Minor + au = P.char '+' >> return Augmented + dm = P.char 'o' >> return Diminished + dm7 = P.try (P.string "o7" >> return Diminished_7) + hdm = P.char 'Ø' >> return Half_Diminished + sus2 = P.try (P.string "sus2" >> return Suspended_2) + sus4 = P.try (P.string "sus4" >> return Suspended_4) + in P.option Major (P.choice [dm7,dm,hdm,au,sus2,sus4,m]) + +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 :: T.P (Maybe Pc) +p_bass = P.optionMaybe (P.char '/' >> p_pc) + +p_chord :: T.P Chord +p_chord = do + pc <- p_pc + ty <- p_chord_type + ex <- P.optionMaybe p_extension + b <- p_bass + ty' <- p_chord_type + let ty'' = case (ty,ty') of + (Major,Suspended_2) -> Suspended_2 + (Major,Suspended_4) -> Suspended_4 + (_,Major) -> ty -- ie. nothing + _ -> error ("trailing type not sus2 or sus4: " ++ show ty') + return (Chord pc ty'' ex b) + +-- | Parse chord. +-- +-- > let ch = words "CmM7 C#o EbM7 Fo7 Gx/D C/E GØ/F Bbsus4/C E7sus2" +-- > let c = map parse_chord ch +-- > map chord_pp c == ch +-- > map chord_pcset c +parse_chord :: String -> Chord +parse_chord = + either (\e -> error ("parse_chord failed\n" ++ show e)) id . + P.parse p_chord "" diff --git a/Music/Theory/Pitch/Note.hs b/Music/Theory/Pitch/Note.hs --- a/Music/Theory/Pitch/Note.hs +++ b/Music/Theory/Pitch/Note.hs @@ -1,49 +1,95 @@ -- | Common music notation note and alteration values. module Music.Theory.Pitch.Note where +import Data.Char {- base -} import Data.Maybe {- base -} +import qualified Text.Parsec as P {- parsec -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Parse as T {- hmt -} + -- * Note -- | Enumeration of common music notation note names (@C@ to @B@). -data Note_T = C | D | E | F | G | A | B - deriving (Eq,Enum,Bounded,Ord,Show) +data Note = C | D | E | F | G | A | B + deriving (Eq,Enum,Bounded,Ord,Read,Show) --- | Transform 'Note_T' to pitch-class number. +-- | Note sequence as usually understood, ie. 'C' - 'B'. +note_seq :: [Note] +note_seq = [C .. B] + +-- | Char variant of 'show'. +note_pp :: Note -> Char +note_pp = head . show + +-- | Note name in lilypond syntax (ie. lower case). +note_pp_ly :: Note -> String +note_pp_ly = map toLower . show + +-- | 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' to pitch-class number. -- -- > map note_to_pc [C,E,G] == [0,4,7] -note_to_pc :: Integral i => Note_T -> i -note_to_pc n = - case n of - C -> 0 - D -> 2 - E -> 4 - F -> 5 - G -> 7 - A -> 9 - B -> 11 +note_to_pc :: Num i => Note -> i +note_to_pc n = T.lookup_err_msg "note_to_pc" n note_pc_tbl --- | Modal transposition of 'Note_T' value. +-- | 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 +pc_to_note i = T.reverse_lookup i note_pc_tbl + +-- | 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 +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 + +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 -> Note -> [Note] +note_span n1 n2 = + let fn x = toEnum (x `mod` 7) + n1' = fromEnum n1 + n2' = fromEnum n2 + n2'' = if n1' > n2' then n2' + 7 else n2' + in map fn [n1' .. n2''] + -- * Alteration -- | Enumeration of common music notation note alterations. -data Alteration_T = DoubleFlat - | ThreeQuarterToneFlat | Flat | QuarterToneFlat - | Natural - | QuarterToneSharp | Sharp | ThreeQuarterToneSharp - | DoubleSharp - deriving (Eq,Enum,Bounded,Ord,Show) +data Alteration = + DoubleFlat + | ThreeQuarterToneFlat | Flat | QuarterToneFlat + | Natural + | QuarterToneSharp | Sharp | ThreeQuarterToneSharp + | DoubleSharp + deriving (Eq,Enum,Bounded,Ord,Show) -- | Generic form. -generic_alteration_to_diff :: Integral i => Alteration_T -> Maybe i +generic_alteration_to_diff :: Integral i => Alteration -> Maybe i generic_alteration_to_diff a = case a of DoubleFlat -> Just (-2) @@ -53,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 @@ -85,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 @@ -104,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 @@ -134,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 @@ -146,79 +192,184 @@ ThreeQuarterToneSharp -> Sharp _ -> x +-- | Table of Unicode characters for alterations. +alteration_symbol_tbl :: [(Alteration,Char)] +alteration_symbol_tbl = + [(DoubleFlat,'𝄫') + ,(ThreeQuarterToneFlat,'𝄭') + ,(Flat,'♭') + ,(QuarterToneFlat,'𝄳') + ,(Natural,'♮') + ,(QuarterToneSharp,'𝄲') + ,(Sharp,'♯') + ,(ThreeQuarterToneSharp,'𝄰') + ,(DoubleSharp,'𝄪')] + -- | Unicode has entries for /Musical Symbols/ in the range @U+1D100@ -- through @U+1D1FF@. The @3/4@ symbols are non-standard, here they -- correspond to @MUSICAL SYMBOL FLAT DOWN@ and @MUSICAL SYMBOL SHARP -- UP@. -- -- > map alteration_symbol [minBound .. maxBound] == "𝄫𝄭♭𝄳♮𝄲♯𝄰𝄪" -alteration_symbol :: Alteration_T -> Char -alteration_symbol a = case a of - DoubleFlat -> '𝄫' - ThreeQuarterToneFlat -> '𝄭' - Flat -> '♭' - QuarterToneFlat -> '𝄳' - Natural -> '♮' - QuarterToneSharp -> '𝄲' - Sharp -> '♯' - ThreeQuarterToneSharp -> '𝄰' - DoubleSharp -> '𝄪' +alteration_symbol :: Alteration -> Char +alteration_symbol a = fromMaybe (error "alteration_symbol") (lookup a alteration_symbol_tbl) --- | The @ISO@ ASCII spellings for alterations. Naturals as written +-- | Inverse of 'alteration_symbol'. +-- +-- > mapMaybe symbol_to_alteration "♭♮♯" == [Flat,Natural,Sharp] +symbol_to_alteration :: Char -> Maybe Alteration +symbol_to_alteration c = T.reverse_lookup c alteration_symbol_tbl + +-- | 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 + 'x' -> Just DoubleSharp + _ -> symbol_to_alteration c + +-- | ISO alteration table, strings not characters because of double flat. +alteration_iso_tbl :: [(Alteration,String)] +alteration_iso_tbl = + [(DoubleFlat,"bb") + ,(Flat,"b") + ,(Natural,"") + ,(Sharp,"#") + ,(DoubleSharp,"x")] + +-- | The @ISO@ ASCII spellings for alterations. Naturals are written -- as the empty string. -- -- > mapMaybe alteration_iso_m [Flat .. Sharp] == ["b","","#"] -alteration_iso_m :: Alteration_T -> Maybe String -alteration_iso_m a = - case a of - DoubleFlat -> Just "bb" - ThreeQuarterToneFlat -> Nothing - Flat -> Just "b" - QuarterToneFlat -> Nothing - Natural -> Just "" - QuarterToneSharp -> Nothing - Sharp -> Just "#" - ThreeQuarterToneSharp -> Nothing - DoubleSharp -> Just "x" +-- > mapMaybe alteration_iso_m [DoubleFlat,DoubleSharp] == ["bb","x"] +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, String)] +alteration_tonh_tbl = + [(DoubleFlat,"eses") + ,(ThreeQuarterToneFlat,"eseh") + ,(Flat,"es") + ,(QuarterToneFlat,"eh") + ,(Natural,"") + ,(QuarterToneSharp,"ih") + ,(Sharp,"is") + ,(ThreeQuarterToneSharp,"isih") + ,(DoubleSharp,"isis")] + +-- | The /Tonhöhe/ ASCII spellings for alterations. -- -- See and -- -- -- > map alteration_tonh [Flat .. Sharp] == ["es","eh","","ih","is"] -alteration_tonh :: Alteration_T -> String -alteration_tonh a = - case a of - DoubleFlat -> "eses" - ThreeQuarterToneFlat -> "eseh" - Flat -> "es" - QuarterToneFlat -> "eh" - Natural -> "" - QuarterToneSharp -> "ih" - Sharp -> "is" - ThreeQuarterToneSharp -> "isih" - DoubleSharp -> "isis" +alteration_tonh :: Alteration -> String +alteration_tonh a = T.lookup_err a alteration_tonh_tbl --- * Generalised Alteration +-- | Inverse of 'alteration_tonh'. +-- +-- > mapMaybe tonh_to_alteration ["es","eh","","ih","is"] == [Flat .. Sharp] +tonh_to_alteration :: String -> Maybe Alteration +tonh_to_alteration s = T.reverse_lookup s alteration_tonh_tbl --- | Generalised alteration, given as a rational semitone difference +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,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) + +-- | Error variant. +-- +-- > map note_alteration_to_pc_err [(A,DoubleSharp),(B,Sharp),(C,Flat),(C,DoubleFlat)] +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, 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,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,Alteration) +pc_to_note_alteration_ks i = T.reverse_lookup i pc_note_alteration_ks_tbl + +-- * Rational Alteration + +-- | Alteration given as a rational semitone difference -- and a string representation of the alteration. -type Alteration_T' = (Rational,String) +type Alteration_R = (Rational,String) --- | Transform 'Alteration_T' to 'Alteration_T''. +-- | Transform 'Alteration' to 'Alteration_R'. -- -- > let r = [(-1,"♭"),(0,"♮"),(1,"♯")] --- > in map alteration_t' [Flat,Natural,Sharp] == r -alteration_t' :: Alteration_T -> Alteration_T' -alteration_t' a = (alteration_to_fdiff a,[alteration_symbol a]) +-- > map alteration_r [Flat,Natural,Sharp] == r +alteration_r :: Alteration -> Alteration_R +alteration_r a = (alteration_to_fdiff a,[alteration_symbol a]) --- | Function to spell a 'PitchClass'. -type Spelling n = n -> (Note_T,Alteration_T) +-- * Parsers +-- | 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") + +-- | 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") + +-- | 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") + +-- | 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 (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 + return (n,a) diff --git a/Music/Theory/Pitch/Note/Name.hs b/Music/Theory/Pitch/Note/Name.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Note/Name.hs @@ -0,0 +1,88 @@ +-- | Constants names for notes. /eses/ indicates double +-- flat, /eseh/ three quarter tone flat, /es/ flat, /eh/ quarter tone +-- flat, /ih/ quarter tone sharp, /is/ sharp, /isih/ three quarter +-- tone sharp and /isis/ double sharp. +module Music.Theory.Pitch.Note.Name where + +import Music.Theory.Pitch.Note + +ceses,deses,eeses,feses,geses,aeses,beses :: (Note,Alteration) +ceses = (C,DoubleFlat) +deses = (D,DoubleFlat) +eeses = (E,DoubleFlat) +feses = (F,DoubleFlat) +geses = (G,DoubleFlat) +aeses = (A,DoubleFlat) +beses = (B,DoubleFlat) + +ceseh,deseh,eeseh,feseh,geseh,aeseh,beseh :: (Note,Alteration) +ceseh = (C,ThreeQuarterToneFlat) +deseh = (D,ThreeQuarterToneFlat) +eeseh = (E,ThreeQuarterToneFlat) +feseh = (F,ThreeQuarterToneFlat) +geseh = (G,ThreeQuarterToneFlat) +aeseh = (A,ThreeQuarterToneFlat) +beseh = (B,ThreeQuarterToneFlat) + +ces,des,ees,fes,ges,aes,bes :: (Note,Alteration) +ces = (C,Flat) +des = (D,Flat) +ees = (E,Flat) +fes = (F,Flat) +ges = (G,Flat) +aes = (A,Flat) +bes = (B,Flat) + +ceh,deh,eeh,feh,geh,aeh,beh :: (Note,Alteration) +ceh = (C,QuarterToneFlat) +deh = (D,QuarterToneFlat) +eeh = (E,QuarterToneFlat) +feh = (F,QuarterToneFlat) +geh = (G,QuarterToneFlat) +aeh = (A,QuarterToneFlat) +beh = (B,QuarterToneFlat) + +c,d,e,f,g,a,b :: (Note,Alteration) +c = (C,Natural) +d = (D,Natural) +e = (E,Natural) +f = (F,Natural) +g = (G,Natural) +a = (A,Natural) +b = (B,Natural) + +cih,dih,eih,fih,gih,aih,bih :: (Note,Alteration) +cih = (C,QuarterToneSharp) +dih = (D,QuarterToneSharp) +eih = (E,QuarterToneSharp) +fih = (F,QuarterToneSharp) +gih = (G,QuarterToneSharp) +aih = (A,QuarterToneSharp) +bih = (B,QuarterToneSharp) + +cis,dis,eis,fis,gis,ais,bis :: (Note,Alteration) +cis = (C,Sharp) +dis = (D,Sharp) +eis = (E,Sharp) +fis = (F,Sharp) +gis = (G,Sharp) +ais = (A,Sharp) +bis = (B,Sharp) + +cisih,disih,eisih,fisih,gisih,aisih,bisih :: (Note,Alteration) +cisih = (C,ThreeQuarterToneSharp) +disih = (D,ThreeQuarterToneSharp) +eisih = (E,ThreeQuarterToneSharp) +fisih = (F,ThreeQuarterToneSharp) +gisih = (G,ThreeQuarterToneSharp) +aisih = (A,ThreeQuarterToneSharp) +bisih = (B,ThreeQuarterToneSharp) + +cisis,disis,eisis,fisis,gisis,aisis,bisis :: (Note,Alteration) +cisis = (C,DoubleSharp) +disis = (D,DoubleSharp) +eisis = (E,DoubleSharp) +fisis = (F,DoubleSharp) +gisis = (G,DoubleSharp) +aisis = (A,DoubleSharp) +bisis = (B,DoubleSharp) diff --git a/Music/Theory/Pitch/Spelling.hs b/Music/Theory/Pitch/Spelling.hs --- a/Music/Theory/Pitch/Spelling.hs +++ b/Music/Theory/Pitch/Spelling.hs @@ -1,75 +1,19 @@ -- | Spelling rules for common music notation. module Music.Theory.Pitch.Spelling where -import Music.Theory.Pitch.Note (Note_T(..),Alteration_T(..),Spelling) - --- | Variant of 'Spelling' for incomplete functions. -type Spelling_M i = i -> Maybe (Note_T, Alteration_T) - --- | Spelling for natural (♮) notes only. --- --- > map pc_spell_natural_m [0,1] == [Just (C,Natural),Nothing] -pc_spell_natural_m :: Integral i => Spelling_M i -pc_spell_natural_m pc = - case pc of - 0 -> Just (C,Natural) - 2 -> Just (D,Natural) - 4 -> Just (E,Natural) - 5 -> Just (F,Natural) - 7 -> Just (G,Natural) - 9 -> Just (A,Natural) - 11 -> Just (B,Natural) - _ -> Nothing - --- | Erroring variant of 'pc_spell_natural_m'. --- --- > map pc_spell_natural [0,5,7] == [(C,Natural),(F,Natural),(G,Natural)] -pc_spell_natural :: Integral i => Spelling i -pc_spell_natural pc = - case pc_spell_natural_m pc of - Just p -> p - _ -> error "pc_spell_natural" - --- | Use spelling from simplest key-signature. Note that this is --- ambiguous for @8@, which could be either G Sharp (♯) in /A Major/ --- or A Flat (♭) in /E Flat (♭) Major/. --- --- > map pc_spell_ks [6,8] == [(F,Sharp),(A,Flat)] -pc_spell_ks :: Integral i => Spelling i -pc_spell_ks pc = - case pc of - 1 -> (C,Sharp) -- 2# - 3 -> (E,Flat) -- 3b - 6 -> (F,Sharp) -- 1# - 8 -> (A,Flat) -- 3b/3# - 10 -> (B,Flat) -- 1b - _ -> pc_spell_natural pc +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Cluster as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Key as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Table as T {- hmt -} --- | Use always sharp (♯) spelling. --- --- > map pc_spell_sharp [6,8] == [(F,Sharp),(G,Sharp)] --- > Data.List.nub (map (snd . pc_spell_sharp) [1,3,6,8,10]) == [Sharp] --- > octpc_to_pitch pc_spell_sharp (4,6) == Pitch F Sharp 4 -pc_spell_sharp :: Integral i => Spelling i -pc_spell_sharp pc = - case pc of - 1 -> (C,Sharp) - 3 -> (D,Sharp) - 6 -> (F,Sharp) - 8 -> (G,Sharp) - 10 -> (A,Sharp) - _ -> pc_spell_natural pc +spell_octpc_set :: [T.OctPc] -> [T.Pitch] +spell_octpc_set o = + case T.octpc_spell_implied_key o of + Just r -> r + Nothing -> + case T.spell_cluster_octpc o of + Just r -> r + Nothing -> map T.octpc_to_pitch_ks o --- | Use always flat (♭) spelling. --- --- > map pc_spell_flat [6,8] == [(G,Flat),(A,Flat)] --- > Data.List.nub (map (snd . pc_spell_flat) [1,3,6,8,10]) == [Flat] -pc_spell_flat :: Integral i => Spelling i -pc_spell_flat pc = - case pc of - 1 -> (D,Flat) - 3 -> (E,Flat) - 6 -> (G,Flat) - 8 -> (A,Flat) - 10 -> (B,Flat) - _ -> pc_spell_natural pc +spell_midi_set :: Integral i => [i] -> [T.Pitch] +spell_midi_set = spell_octpc_set . map T.midi_to_octave_pitchclass diff --git a/Music/Theory/Pitch/Spelling/Cluster.hs b/Music/Theory/Pitch/Spelling/Cluster.hs --- a/Music/Theory/Pitch/Spelling/Cluster.hs +++ b/Music/Theory/Pitch/Spelling/Cluster.hs @@ -1,128 +1,175 @@ -- | Spelling for chromatic clusters. module Music.Theory.Pitch.Spelling.Cluster where -import Data.List -import Music.Theory.Pitch -import Music.Theory.Pitch.Name +import Data.List {- base -} --- | Spelling table for chromatic clusters. +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +import Music.Theory.Pitch.Note.Name {- hmt -} + +-- | Form of cluster with smallest outer boundary interval. -- --- > let f (p,q) = p == sort (map (snd . pitch_to_octpc) q) --- > in all f spell_cluster_c4_table == True -spell_cluster_c4_table :: [([PitchClass],[Pitch])] -spell_cluster_c4_table = - [([0],[c4]) - ,([0,1],[c4,des4]) - ,([0,1,2],[bis3,cis4,d4]) - ,([0,1,2,3],[bis3,cis4,d4,ees4]) - ,([0,1,2,3,10,11],[ais3,b3,c4,cis4,d4,ees4]) -- overlap... - ,([0,1,2,10],[ais3,bis3,cis4,d4]) - ,([0,1,2,11],[aisis3,bis3,cis4,d4]) - ,([0,1,3],[c4,des4,ees4]) - ,([0,1,3,10],[bes3,c4,des4,ees4]) - ,([0,1,3,11],[b3,c4,des4,ees4]) - ,([0,1,10],[bes3,c4,des4]) - ,([0,1,10,11],[ais3,b3,c4,des4]) - ,([0,1,11],[b3,c4,des4]) - ,([0,2],[c4,d4]) - ,([0,2,3],[c4,d4,ees4]) - ,([0,2,3,10],[bes3,c4,d4,ees4]) - ,([0,2,3,11],[b3,c4,d4,ees4]) - ,([0,2,11],[b3,c4,d4]) - ,([0,2,10],[bes3,c4,d4]) - ,([0,2,10,11],[ais3,b3,c4,d4]) - ,([0,3,10,11],[ais3,b3,c4,dis4]) - ,([0,3,11],[b3,c4,dis4]) - ,([0,10,11],[ais3,b3,c4]) - ,([0,11],[b3,c4]) - ,([1],[cis4]) - ,([1,2],[cis4,d4]) - ,([1,2,3],[cis4,d4,ees4]) - ,([1,2,3,10],[bes3,cis4,d4,ees4]) - ,([1,2,3,11],[b3,cis4,d4,ees4]) - ,([1,2,10],[ais3,cis4,d4]) - ,([1,2,10,11],[ais3,b3,cis4,d4]) - ,([1,2,11],[b3,cis4,d4]) - ,([1,3,11],[b3,cis4,dis4]) - ,([1,3,10,11],[ais3,b3,cis4,dis4]) - ,([1,10,11],[ais3,b3,cis4]) - ,([1,11],[b3,cis4]) - ,([2],[d4]) - ,([2,3],[d4,ees4]) - ,([2,3,4],[d4,ees4,fes4]) - ,([2,3,5],[d4,ees4,f4]) - ,([2,3,4,5],[d4,ees4,fes4,geses4]) - ,([2,3,10,11],[bes3,ces4,d4,ees4]) - ,([2,3,11],[b3,d4,ees4]) - ,([2,4],[d4,e4]) - ,([2,4,5],[d4,e4,f4]) - ,([2,5],[d4,f4]) - ,([2,10,11],[ais3,b3,d4]) - ,([2,11],[b3,d4]) - ,([3],[ees4]) - ,([3,4],[dis4,e4]) - ,([3,4,5],[dis4,e4,f4]) - ,([3,5],[ees4,f4]) - ,([4],[e4]) - ,([4,5],[e4,f4]) - ,([5],[f4]) - ,([5,6],[f4,ges4]) - ,([5,6,7],[eis4,fis4,g4]) - ,([5,6,8],[f4,ges4,aes4]) - ,([5,6,9],[f4,ges4,a4]) - ,([5,6,7,8],[eis4,fis4,g4,aes4]) - ,([5,6,7,8,9],[eis4,fis4,g4,aes4,beses4]) - ,([5,6,7,9],[eis4,fis4,g4,a4]) - ,([5,6,8,9],[eis4,fis4,gis4,a4]) - ,([5,7],[f4,g4]) - ,([5,7,8],[f4,g4,aes4]) - ,([5,7,8,9],[f4,g4,aes4,beses4]) - ,([5,7,9],[f4,g4,a4]) - ,([5,8],[f4,aes4]) - ,([5,8,9],[f4,gis4,a4]) - ,([5,9],[f4,a4]) - ,([6],[fis4]) - ,([6,7],[fis4,g4]) - ,([6,7,8],[fis4,g4,aes4]) - ,([6,7,8,9],[fis4,g4,aes4,beses4]) - ,([6,7,9],[fis4,g4,a4]) - ,([6,8],[fis4,gis4]) - ,([6,8,9],[fis4,gis4,a4]) - ,([6,9],[fis4,a4]) - ,([7],[g4]) - ,([7,8],[g4,aes4]) - ,([7,8,9],[fisis4,gis4,a4]) - ,([7,9],[g4,a4]) - ,([8],[aes4]) - ,([8,9],[gis4,a4]) - ,([8,9,10],[gis4,a4,bes4]) - ,([8,10],[aes4,bes4]) - ,([9],[a4]) - ,([9,10],[a4,bes4]) - ,([10],[bes4]) - ,([10,11],[ais4,b4]) - ,([11],[b4])] +-- > cluster_normal_order [0,1,11] == [11,0,1] +cluster_normal_order :: [T.PitchClass] -> [T.PitchClass] +cluster_normal_order = + let with_bounds x = ((last x - head x) `mod` 12,x) + 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 o pc = + let pc_n = cluster_normal_order pc + pc_0 = head pc_n + in map (\x -> (if x >= pc_0 then o else o + 1,x)) pc_n + +-- | True if 'sort' of cluster is not equal to 'cluster_normal_order'. +-- +-- > map cluster_is_multiple_octave [[0,1,11],[1,2,3],[1,2,11]] == [True,False,True] +cluster_is_multiple_octave :: [T.PitchClass] -> Bool +cluster_is_multiple_octave x = sort x /= cluster_normal_order x + +-- | Spelling table for chromatic and near-chromatic clusters, +-- pitch-classes are in cluster order. +-- +-- > 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.Alteration)])] +spell_cluster_table = + [([0,1,2,3],[bis,cis,d,ees]) + ,([0,1,2],[bis,cis,d]) + ,([0,1,3],[c,des,ees]) + ,([0,1],[c,des]) + ,([0,2,3],[c,d,ees]) + ,([0,2],[c,d]) + ,([0],[c]) + ,([1,2,3],[cis,d,ees]) + ,([1,2],[cis,d]) + ,([10,0,1,2],[ais,bis,cis,d]) + ,([10,0,1,3],[bes,c,des,ees]) + ,([10,0,1],[bes,c,des]) + ,([10,0,2,3],[bes,c,d,ees]) + ,([10,0,2],[bes,c,d]) + ,([10,1,2,3],[bes,cis,d,ees]) + ,([10,1,2],[ais,cis,d]) + ,([10,11,0,1,2,3],[ais,b,c,cis,d,ees]) -- overlap... + ,([10,11,0,1],[ais,b,c,des]) + ,([10,11,0,2],[ais,b,c,d]) + ,([10,11,0,3],[ais,b,c,dis]) + ,([10,11,0],[ais,b,c]) + ,([10,11,1,2],[ais,b,cis,d]) + ,([10,11,1,3],[ais,b,cis,dis]) + ,([10,11,1],[ais,b,cis]) + ,([10,11,2,3],[bes,ces,d,ees]) + ,([10,11,2],[ais,b,d]) + ,([10,11],[ais,b]) + ,([10],[bes]) + ,([11,0,1,2],[aisis,bis,cis,d]) + ,([11,0,1,3],[b,c,des,ees]) + ,([11,0,1],[b,c,des]) + ,([11,0,2,3],[b,c,d,ees]) + ,([11,0,2],[b,c,d]) + ,([11,0,3],[b,c,dis]) + ,([11,0],[b,c]) + ,([11,1,2,3],[b,cis,d,ees]) + ,([11,1,2],[b,cis,d]) + ,([11,1,3],[b,cis,dis]) + ,([11,1],[b,cis]) + ,([11,2,3],[b,d,ees]) + ,([11,2],[b,d]) + ,([11],[b]) + ,([1],[cis]) + ,([2,3,4,5],[d,ees,fes,geses]) + ,([2,3,4],[d,ees,fes]) + ,([2,3,5],[d,ees,f]) + ,([2,3],[d,ees]) + ,([2,4,5],[d,e,f]) + ,([2,4],[d,e]) + ,([2,5],[d,f]) + ,([2],[d]) + ,([3,4,5],[dis,e,f]) + ,([3,4],[dis,e]) + ,([3,5],[ees,f]) + ,([3],[ees]) + ,([4,5],[e,f]) + ,([4],[e]) + ,([5,6,7,8,9],[eis,fis,g,aes,beses]) + ,([5,6,7,8],[eis,fis,g,aes]) + ,([5,6,7,9],[eis,fis,g,a]) + ,([5,6,7],[eis,fis,g]) + ,([5,6,8,9],[eis,fis,gis,a]) + ,([5,6,8],[f,ges,aes]) + ,([5,6,9],[f,ges,a]) + ,([5,6],[f,ges]) + ,([5,7,8,9],[f,g,aes,beses]) + ,([5,7,8],[f,g,aes]) + ,([5,7,9],[f,g,a]) + ,([5,7],[f,g]) + ,([5,8,9],[f,gis,a]) + ,([5,8],[f,aes]) + ,([5,9],[f,a]) + ,([5],[f]) + ,([6,7,8,9],[fis,g,aes,beses]) + ,([6,7,8],[fis,g,aes]) + ,([6,7,9],[fis,g,a]) + ,([6,7],[fis,g]) + ,([6,8,9],[fis,gis,a]) + ,([6,8],[fis,gis]) + ,([6,9],[fis,a]) + ,([6],[fis]) + ,([7,8,9],[fisis,gis,a]) + ,([7,8],[g,aes]) + ,([7,9],[g,a]) + ,([7],[g]) + ,([8,10],[aes,bes]) + ,([8,9,10],[gis,a,bes]) + ,([8,9],[gis,a]) + ,([8],[aes]) + ,([9,10],[a,bes]) + ,([9],[a])] + +spell_cluster :: [T.PitchClass] -> Maybe [(T.Note,T.Alteration)] +spell_cluster = flip lookup spell_cluster_table + +-- | 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 o = + let p = cluster_normal_order (sort (nub (map snd o))) + na_f na = + let na_tbl = map (\x -> (T.note_alteration_to_pc_err x,x)) na + o_f (oct,pc) = let (n,alt) = T.lookup_err pc na_tbl in T.Pitch n alt oct + in map o_f o + in fmap na_f (spell_cluster p) + -- | Spelling for chromatic clusters. Sequence must be ascending. -- Pitch class @0@ maps to 'c4', if there is no @0@ then all notes are -- in octave @4@. -- --- > let f = fmap (map pitch_pp) . spell_cluster_c4 --- > in map f [[11,0],[11]] == [Just ["B3","C4"],Just ["B4"]] +-- > let f = (fmap (map T.pitch_pp) . spell_cluster_c4) +-- > map f [[11,0],[11],[0,11]] == [Just ["B3","C4"],Just ["B4"],Nothing] -- --- > fmap (map pitch_pp) (spell_cluster_c4 [10,11]) == Just ["A♯4","B4"] -spell_cluster_c4 :: [PitchClass] -> Maybe [Pitch] -spell_cluster_c4 p = lookup (sort p) spell_cluster_c4_table +-- > fmap (map T.pitch_pp) (spell_cluster_c4 [10,11]) == Just ["A♯4","B4"] +spell_cluster_c4 :: [T.PitchClass] -> Maybe [T.Pitch] +spell_cluster_c4 p = + let o_0 = if cluster_is_multiple_octave p then 3 else 4 + oct = map fst (cluster_normal_order_octpc o_0 p) + in case spell_cluster p of + Nothing -> Nothing + 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 -- above. -- --- > fmap (map pitch_pp) (spell_cluster_c 3 [11,0]) == Just ["B2","C3"] --- > fmap (map pitch_pp) (spell_cluster_c 3 [10,11]) == Just ["A♯3","B3"] -spell_cluster_c :: Octave -> [PitchClass] -> Maybe [Pitch] +-- > fmap (map T.pitch_pp) (spell_cluster_c 3 [11,0]) == Just ["B2","C3"] +-- > fmap (map T.pitch_pp) (spell_cluster_c 3 [10,11]) == Just ["A♯3","B3"] +spell_cluster_c :: T.Octave -> [T.PitchClass] -> Maybe [T.Pitch] spell_cluster_c o = - fmap (map (pitch_edit_octave (+ (o - 4)))) . + fmap (map (T.pitch_edit_octave (+ (o - 4)))) . spell_cluster_c4 -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so @@ -130,28 +177,30 @@ -- -- > import Data.Maybe -- --- > let {f n = if n >= 11 then 3 else 4 --- > ;g = map 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 -spell_cluster_f :: (PitchClass -> Octave) -> [PitchClass] -> Maybe [Pitch] +-- > 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] spell_cluster_f o_f p = let fn r = case r of [] -> [] - l:_ -> let (o,n) = pitch_to_octpc l - f = (+ (o_f n - o)) - in (map (pitch_edit_octave f) r) + 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 fmap fn (spell_cluster_c4 p) -- | Variant of 'spell_cluster_c4' that runs 'pitch_edit_octave' so -- that the left-most note is in octave /o/. -- --- > fmap (map pitch_pp) (spell_cluster_left 3 [11,0]) == Just ["B3","C4"] --- > fmap (map pitch_pp) (spell_cluster_left 3 [10,11]) == Just ["A♯3","B3"] -spell_cluster_left :: Octave -> [PitchClass] -> Maybe [Pitch] +-- > fmap (map T.pitch_pp) (spell_cluster_left 3 [11,0]) == Just ["B3","C4"] +-- > fmap (map T.pitch_pp) (spell_cluster_left 3 [10,11]) == Just ["A♯3","B3"] +spell_cluster_left :: T.Octave -> [T.PitchClass] -> Maybe [T.Pitch] spell_cluster_left o p = let fn r = case r of [] -> [] - l:_ -> let f = (+ (o - octave l)) - in map (pitch_edit_octave f) r + l:_ -> let oct_f = (+ (o - T.octave l)) + in map (T.pitch_edit_octave oct_f) r in fmap fn (spell_cluster_c4 p) diff --git a/Music/Theory/Pitch/Spelling/Key.hs b/Music/Theory/Pitch/Spelling/Key.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Spelling/Key.hs @@ -0,0 +1,33 @@ +module Music.Theory.Pitch.Spelling.Key where + +import qualified Music.Theory.Key as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +import qualified Music.Theory.Pitch.Spelling.Table as T {- hmt -} + +pcset_spell_implied_key_f :: Integral i => [i] -> Maybe (T.Spelling i) +pcset_spell_implied_key_f x = + case T.implied_fifths T.Major_Mode x of + Nothing -> Nothing + Just n -> if n == 0 + then Just T.pc_spell_natural + else if n < 0 + then Just T.pc_spell_flat + 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.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 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)) + +-- > map (fmap (map T.pitch_pp_iso) . midi_spell_implied_key) [[59,61],[59,70]] +midi_spell_implied_key :: [T.Midi] -> Maybe [T.Pitch] +midi_spell_implied_key = octpc_spell_implied_key . map T.midi_to_octpc diff --git a/Music/Theory/Pitch/Spelling/Table.hs b/Music/Theory/Pitch/Spelling/Table.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Pitch/Spelling/Table.hs @@ -0,0 +1,105 @@ +-- | Simple table based spelling rules for common music notation. +module Music.Theory.Pitch.Spelling.Table where + +import Data.Maybe {- base -} + +import qualified Music.Theory.Pitch as T {- hmt -} +import Music.Theory.Pitch.Note {- hmt -} + +type Spelling_Table i = [(i,(Note,Alteration))] + +-- | Spelling table for natural (♮) notes only. +pc_spell_natural_tbl :: Integral i => Spelling_Table i +pc_spell_natural_tbl = + [(0,(C,Natural)) + ,(2,(D,Natural)) + ,(4,(E,Natural)) + ,(5,(F,Natural)) + ,(7,(G,Natural)) + ,(9,(A,Natural)) + ,(11,(B,Natural))] + +-- | Spelling table for sharp (♯) notes only. +pc_spell_sharp_tbl :: Integral i => Spelling_Table i +pc_spell_sharp_tbl = + [(1,(C,Sharp)) + ,(3,(D,Sharp)) + ,(6,(F,Sharp)) + ,(8,(G,Sharp)) + ,(10,(A,Sharp))] + +-- | Spelling table for flat (♭) notes only. +pc_spell_flat_tbl :: Integral i => Spelling_Table i +pc_spell_flat_tbl = + [(1,(D,Flat)) + ,(3,(E,Flat)) + ,(6,(G,Flat)) + ,(8,(A,Flat)) + ,(10,(B,Flat))] + +-- | Spelling table from simplest key-signature. Note that this is +-- ambiguous for @8@, which could be either G Sharp (♯) in /A Major/ +-- or A Flat (♭) in /E Flat (♭) Major/. +pc_spell_ks_tbl :: Integral i => Spelling_Table i +pc_spell_ks_tbl = + [(1,(C,Sharp)) -- 2♯ + ,(3,(E,Flat)) -- 3♭ + ,(6,(F,Sharp)) -- 1♯ + ,(8,(A,Flat)) -- 3♭/3♯ + ,(10,(B,Flat))] -- 1♭ + +pc_spell_tbl :: Integral i => Spelling_Table i -> T.Spelling i +pc_spell_tbl tbl = fromMaybe (error "pc_spell_tbl") . flip lookup tbl + +-- | Spell using indicated table prepended to and 'pc_spell_natural_tbl' and 'pc_spell_ks_tbl' +pc_spell_tbl_ks :: Integral i => Spelling_Table i -> T.Spelling i +pc_spell_tbl_ks tbl = pc_spell_tbl (tbl ++ pc_spell_natural_tbl ++ pc_spell_ks_tbl) + +-- | Spelling for natural (♮) notes only. +-- +-- > map pc_spell_natural_m [0,1] == [Just (C,Natural),Nothing] +pc_spell_natural_m :: Integral i => T.Spelling_M i +pc_spell_natural_m = flip lookup pc_spell_natural_tbl + +-- | Erroring variant of 'pc_spell_natural_m'. +-- +-- > map pc_spell_natural [0,5,7] == [(C,Natural),(F,Natural),(G,Natural)] +pc_spell_natural :: Integral i => T.Spelling i +pc_spell_natural = pc_spell_tbl pc_spell_natural_tbl + +-- | Lookup 'pc_spell_ks_tbl'. +-- +-- > map pc_spell_ks [6,8] == [(F,Sharp),(A,Flat)] +pc_spell_ks :: Integral i => T.Spelling i +pc_spell_ks = pc_spell_tbl_ks [] + +-- | Use always sharp (♯) spelling. +-- +-- > map pc_spell_sharp [6,8] == [(F,Sharp),(G,Sharp)] +-- > Data.List.nub (map (snd . pc_spell_sharp) [1,3,6,8,10]) == [Sharp] +pc_spell_sharp :: Integral i => T.Spelling i +pc_spell_sharp = pc_spell_tbl (pc_spell_sharp_tbl ++ pc_spell_natural_tbl) + +-- | Use always flat (♭) spelling. +-- +-- > map pc_spell_flat [6,8] == [(G,Flat),(A,Flat)] +-- > Data.List.nub (map (snd . pc_spell_flat) [1,3,6,8,10]) == [Flat] +pc_spell_flat :: Integral i => T.Spelling i +pc_spell_flat = pc_spell_tbl (pc_spell_flat_tbl ++ pc_spell_natural_tbl) + +octpc_to_pitch_ks :: Integral i => T.Octave_PitchClass i -> T.Pitch +octpc_to_pitch_ks = T.octpc_to_pitch 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) + +fmidi_to_pitch_ks :: (Show n,RealFrac n) => n -> T.Pitch +fmidi_to_pitch_ks = T.fmidi_to_pitch_err pc_spell_ks + +midi_detune_to_pitch_ks :: (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) diff --git a/Music/Theory/Random/I_Ching.hs b/Music/Theory/Random/I_Ching.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Random/I_Ching.hs @@ -0,0 +1,219 @@ +-- | YIJING / I-CHING +module Music.Theory.Random.I_Ching where + +import Control.Monad {- base -} +import Data.Maybe {- base -} +import Data.Int {- base -} +import System.Random {- random -} + +import qualified Music.Theory.Bits as T {- hmt-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 + +-- | Line, indicated as sum. +data Line = L6 | L7 | L8 | L9 deriving (Eq,Show) + +{-| (sum={6,7,8,9}, + (yarrow probablity={1,3,5,7}/16, + three-coin probablity={2,6}/16, + name,signification,symbol)) +-} +type Line_Stat = (Line,(Rational,Rational,String,String,String)) + +-- | I-CHING chart as sequence of 4 'Line_Stat'. +i_ching_chart :: [Line_Stat] +i_ching_chart = + [(L6,(1/16,2/16,"old yin","yin changing into yang","---x---")) + ,(L7,(5/16,6/16,"young yang","yang unchanging","-------")) + ,(L8,(7/16,6/16,"young yin","yin unchanging","--- ---")) + ,(L9,(3/16,2/16,"old yang","yang changing into yin","---o---"))] + +-- | Lines L6 and L7 are unbroken (since L6 is becoming L7). +line_unbroken :: Line -> Bool +line_unbroken n = n `elem` [L6,L7] + +-- | If /b/ then L7 else L8. +line_from_bit :: Bool -> Line +line_from_bit b = if b then L7 else L8 + +-- | Seven character ASCII string for line. +line_ascii_pp :: Line -> String +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 +line_is_moving n = n `elem` [L6,L9] + +-- | Old yin (L6) becomes yang (L7), and old yang (L9) becomes yin (L8). +line_complement :: Line -> Maybe Line +line_complement n = + case n of + L6 -> Just L7 + L9 -> Just L8 + _ -> Nothing + +{- | Sequence of sum values assigned to ascending four bit numbers. + Sequence is in ascending probablity, ie: 1×6,3×9,5×7,7×8. + +> import Music.Theory.Bits {- hmt -} +> zip (map (gen_bitseq_pp 4) [0::Int .. 15]) (map line_ascii_pp four_coin_sequence) + +-} +four_coin_sequence :: [Line] +four_coin_sequence = + [L6,L9,L9,L9 + ,L7,L7,L7,L7 + ,L7,L8,L8,L8 + ,L8,L8,L8,L8] + +-- * HEXAGRAM + +-- | Sequence of 6 'Line'. +type Hexagram = [Line] + +-- | Hexagrams are drawn upwards. +hexagram_pp :: Hexagram -> String +hexagram_pp = unlines . reverse . map line_ascii_pp + +-- | Generate hexagram (ie. sequence of six lines given by sum) using 'four_coin_sequence'. +-- +-- > four_coin_gen_hexagram >>= putStrLn . hexagram_pp +four_coin_gen_hexagram :: IO Hexagram +four_coin_gen_hexagram = fmap (map (four_coin_sequence !!)) (replicateM 6 (randomRIO (0,15))) + +-- | 'any' of 'line_is_moving'. +hexagram_has_complement :: Hexagram -> Bool +hexagram_has_complement = any line_is_moving + +-- | If 'hexagram_has_complement' then derive it. +-- +-- > h <- four_coin_gen_hexagram +-- > putStrLn (hexagram_pp h) +-- > maybe (return ()) (putStrLn . hexagram_pp) (hexagram_complement h) +hexagram_complement :: Hexagram -> Maybe Hexagram +hexagram_complement h = + let f n = fromMaybe n (line_complement n) + in if hexagram_has_complement h then Just (map f h) else Nothing + +-- | Names of hexagrams, in King Wen order (see also data/csv/combinatorics/yijing.csv) +-- +-- > length hexagram_names == 64 +hexagram_names :: [(String,String)] +hexagram_names = + [("乾","qián") + ,("坤","kūn") + ,("屯","zhūn") + ,("蒙","méng") + ,("需","xū") + ,("訟","sòng") + ,("師","shī") + ,("比","bǐ") + ,("小畜","xiǎo chù") + ,("履","lǚ") + ,("泰","tài") + ,("否","pǐ") + ,("同人","tóng rén") + ,("大有","dà yǒu") + ,("謙","qiān") + ,("豫","yù") + ,("隨","suí") + ,("蠱","gŭ") + ,("臨","lín") + ,("觀","guān") + ,("噬嗑","shì kè") + ,("賁","bì") + ,("剝","bō") + ,("復","fù") + ,("無妄","wú wàng") + ,("大畜","dà chù") + ,("頤","yí") + ,("大過","dà guò") + ,("坎","kǎn") + ,("離","lí") + ,("咸","xián") + ,("恆","héng") + ,("遯","dùn") + ,("大壯","dà zhuàng") + ,("晉","jìn") + ,("明夷","míng yí") + ,("家人","jiā rén") + ,("睽","kuí") + ,("蹇","jiǎn") + ,("解","xiè") + ,("損","sǔn") + ,("益","yì") + ,("夬","guài") + ,("姤","gòu") + ,("萃","cuì") + ,("升","shēng") + ,("困","kùn") + ,("井","jǐng") + ,("革","gé") + ,("鼎","dǐng") + ,("震","zhèn") + ,("艮","gèn") + ,("漸","jiàn") + ,("歸妹","guī mèi") + ,("豐","fēng") + ,("旅","lǚ") + ,("巽","xùn") + ,("兌","duì") + ,("渙","huàn") + ,("節","jié") + ,("中孚","zhōng fú") + ,("小過","xiǎo guò") + ,("既濟","jì jì") + ,("未濟","wèi jì")] + +-- | Unicode hexagram characters, in King Wen order. +-- +-- > import Data.List.Split {- split -} +-- > mapM_ putStrLn (chunksOf 8 hexagram_unicode_sequence) +hexagram_unicode_sequence :: [Char] +hexagram_unicode_sequence = map (toEnum . fst) T.yijing_tbl + +-- | Binary form of 'Hexagram'. +hexagram_to_binary :: Hexagram -> Int8 +hexagram_to_binary = T.pack_bitseq . map line_unbroken + +-- | Show binary form. +hexagram_to_binary_str :: Hexagram -> String +hexagram_to_binary_str = T.gen_bitseq_pp 6 . hexagram_to_binary + +-- | Inverse of 'hexagram_to_binary'. +hexagram_from_binary :: Int8 -> Hexagram +hexagram_from_binary = map line_from_bit . T.gen_bitseq 6 + +-- | Read binary form. +-- +-- > let h = hexagram_from_binary_str "100010" +-- > putStrLn (hexagram_pp h) +-- > hexagram_to_binary_str h == "100010" +hexagram_from_binary_str :: String -> Hexagram +hexagram_from_binary_str = hexagram_from_binary . T.read_bin_err + +-- * TRIGRAM + +-- | Unicode sequence of trigrams (unicode order). +-- +-- > import Data.List {- base -} +-- > putStrLn (intersperse ' ' trigram_unicode_sequence) +trigram_unicode_sequence :: [Char] +trigram_unicode_sequence = map (toEnum . fst) T.bagua_tbl + +-- | (INDEX,UNICODE,BIT-SEQUENCE,NAME,NAME-TRANSLITERATION,NATURE-IMAGE,DIRECTION,ANIMAL) +-- +-- > map (T.read_bin_err . T.p8_third) trigram_chart == [7,6,5,4,3,2,1,0] +trigram_chart :: [(Int, Char, String, Char, String, Char, String, Char)] +trigram_chart = + [(1,'☰',"111",'乾',"qián",'天',"NW",'馬') + ,(2,'☱',"110",'兌',"duì",'澤',"W",'羊') + ,(3,'☲',"101",'離',"lí",'火',"S",'雉') + ,(4,'☳',"100",'震',"zhèn",'雷',"E",'龍') + ,(5,'☴',"011",'巽',"xùn",'風',"SE",'雞') + ,(6,'☵',"010",'坎',"kǎn",'水',"N",'豕') + ,(7,'☶',"001",'艮',"gèn",'山',"NE",'狗') + ,(8,'☷',"000",'坤',"kūn",'地',"SW",'牛')] diff --git a/Music/Theory/Random/Jones_1981.hs b/Music/Theory/Random/Jones_1981.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Random/Jones_1981.hs @@ -0,0 +1,60 @@ +-- | Kevin Jones. "Compositional Applications of Stochastic Processes". +-- Computer Music Journal, 5(2):45-58, 1981. +module Music.Theory.Random.Jones_1981 where + +import Data.List {- base -} +import Data.Maybe {- base -} +import System.Random {- random -} + +-- * Stochastic Finite State Grammars + +data G a = T a | P (G a) (G a) deriving (Eq,Show) + +type Rule k a = k -> a -> Maybe (a,a) +type Probablities k r = (r,[(k,r)]) +type SFSG k a r = (Rule k a,Probablities k r) + +-- > p_verify (1/2,[('a',1/4),('b',1/4)]) == True +p_verify :: (Eq a,Num a) => Probablities k a -> Bool +p_verify (t,k) = sum (t : map snd k) == 1 + +p_select :: (Ord a, Num a) => Probablities k a -> a -> Maybe (Maybe k) +p_select (t,k) = + let windex w n = findIndex (n <) (scanl1 (+) w) + (kk,kn) = unzip k + f i = case i of + 0 -> Nothing + _ -> Just (kk !! (i - 1)) + in fmap f . windex (t : kn) + +-- > let p = (1/2,[('a',1/4),('b',1/4)]) +-- > map (p_select_err p) [0,0.5,0.75] == [Nothing,Just 'a',Just 'b'] +p_select_err :: (Ord a, Num a) => Probablities k a -> a -> Maybe k +p_select_err p = fromMaybe (error "p_select") . p_select p + +g_collect :: G a -> [a] +g_collect g = + case g of + T e -> [e] + P p q -> g_collect p ++ g_collect q + +unfold :: (RandomGen g,Random r,Ord r,Num r) => SFSG k a r -> a -> g -> (G a,g) +unfold (r,p) st g = + let (n,g') = randomR (0,1) g + in case p_select_err p n of + Nothing -> (T st,g') + Just k -> + case r k st of + Nothing -> (T st,g') + Just (i,j) -> + let (i',g'') = unfold (r,p) i g' + (j',g''') = unfold (r,p) j g'' + in (P i' j',g''') + +sfsg_chain :: (RandomGen g,Random r,Ord r,Num r) => SFSG k a r -> a -> g -> [G a] +sfsg_chain gr st g = + let (x,g') = unfold gr st g + in x : sfsg_chain gr st g' + +sfsg_chain_n :: (RandomGen g,Random r,Ord r,Num r) => Int -> SFSG k a r -> a -> g -> [G a] +sfsg_chain_n n gr st = take n . sfsg_chain gr st diff --git a/Music/Theory/Set/List.hs b/Music/Theory/Set/List.hs --- a/Music/Theory/Set/List.hs +++ b/Music/Theory/Set/List.hs @@ -1,15 +1,18 @@ -- | Set operations on lists. module Music.Theory.Set.List where -import Control.Monad -import Data.List +import Control.Monad {- base -} +import Data.List {- base -} + import qualified Math.Combinatorics.Multiset as M {- multiset-comb -} --- | Remove duplicate elements with 'nub' and then 'sort'. +import qualified Music.Theory.List as T {- hmt-base -} + +-- | 'sort' then 'nub'. -- --- > set_l [3,3,3,2,2,1] == [1,2,3] +-- > set [3,3,3,2,2,1] == [1,2,3] set :: (Ord a) => [a] -> [a] -set = sort . nub +set = nub . sort -- | Size of powerset of set of cardinality /n/, ie. @2@ '^' /n/. -- @@ -24,6 +27,12 @@ powerset :: [a] -> [[a]] powerset = filterM (const [True,False]) +-- | Variant where result is sorted and the empty set is not given. +-- +-- > 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. -- -- > pairs [1,2,3] == [(1,2),(1,3),(2,3)] @@ -33,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 @@ -54,19 +65,37 @@ 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 of two sets. + +> 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] + +-- | List form of n-fold cartesian product. +-- +-- > length (nfold_cartesian_product [[1..13],[1..4]]) == 52 +-- > length (nfold_cartesian_product ["abc","de","fgh"]) == 3 * 2 * 3 +nfold_cartesian_product :: [[a]] -> [[a]] +nfold_cartesian_product l = + case l of + [] -> [] + [_] -> [] + [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 diff --git a/Music/Theory/Set/Set.hs b/Music/Theory/Set/Set.hs --- a/Music/Theory/Set/Set.hs +++ b/Music/Theory/Set/Set.hs @@ -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 diff --git a/Music/Theory/Tempo_Marking.hs b/Music/Theory/Tempo_Marking.hs --- a/Music/Theory/Tempo_Marking.hs +++ b/Music/Theory/Tempo_Marking.hs @@ -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 @@ -79,7 +79,7 @@ -- | Lookup metronome mark in table. -- -- > mm_name metronome_table_nikko 72 == Just "Andante" -mm_name :: (Num a, Ord a) => [(String,(a,a))] -> a -> Maybe String +mm_name :: Ord a => [(String,(a,a))] -> a -> Maybe String mm_name tbl x = let f (_,(p,q)) = x >= p && x < q in fmap fst (find f tbl) diff --git a/Music/Theory/Tiling/Canon.hs b/Music/Theory/Tiling/Canon.hs --- a/Music/Theory/Tiling/Canon.hs +++ b/Music/Theory/Tiling/Canon.hs @@ -1,11 +1,14 @@ module Music.Theory.Tiling.Canon where -import Control.Monad.Logic {- logict -} -import Data.Function {- base -} +import Control.Monad {- base -} import Data.List {- base -} import Data.List.Split {- split -} import Text.Printf {- base -} +import qualified Control.Monad.Logic as L {- logict -} + +import qualified Music.Theory.List as T {- hmt -} + -- | Sequence. type S = [Int] @@ -35,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) @@ -61,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) @@ -70,28 +74,29 @@ -- | 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) - in map f (groupBy ((==) `on` t3_1) e) + 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] +-- > L.observeAll (fromList [1..7]) == [1..7] fromList :: MonadPlus m => [a] -> m a fromList = msum . map return @@ -113,37 +118,37 @@ rec (m':p) (s'':q) in rec [] [] --- | 't_normal' of 'observeAll' of 'perfect_tilings_m'. --- --- > 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 --- --- > 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,9],[6,8]] --- > ,[[0,1],[2,7],[3,5],[4,8],[6,9]] --- > ,[[0,2],[1,4],[3,8],[5,9],[6,7]] --- > ,[[0,2],[1,5],[3,6],[4,9],[7,8]] --- > ,[[0,3],[1,6],[2,4],[5,9],[7,8]]] --- > in perfect_tilings [[0,1]] [1..5] 10 5 == r --- --- 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] --- --- > 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] +{- | 't_normal' of 'L.observeAll' of 'perfect_tilings_m'. + +> 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]]] +> 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]]] +> 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]] +> ,[[0,2],[1,4],[3,8],[5,9],[6,7]] +> ,[[0,2],[1,5],[3,6],[4,9],[7,8]] +> ,[[0,3],[1,6],[2,4],[5,9],[7,8]]] +> in perfect_tilings [[0,1]] [1..5] 10 5 == r + +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]] +> 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]] +> perfect_tilings [[0,1,2]] [1,2,4,5,7,8,10] 21 7 == [t_retrograde r] + +-} perfect_tilings :: [S] -> [Int] -> Int -> Int -> [T] perfect_tilings s m n = - nub . sort . map t_normal . observeAll . perfect_tilings_m s m n + nub . sort . map t_normal . L.observeAll . perfect_tilings_m s m n -- * Display diff --git a/Music/Theory/Time/Bel1990/R.hs b/Music/Theory/Time/Bel1990/R.hs --- a/Music/Theory/Time/Bel1990/R.hs +++ b/Music/Theory/Time/Bel1990/R.hs @@ -11,184 +11,7 @@ Centre National de la Recherche Scientifique, 1992. /GRTC 458/ () -For patterns without tempo indications, the two notations should give -equivalent phase diagrams, for instance (Bel 1990, §11, p.24): - -> > bel_ascii_pp "ab{ab,cde}cd" -> -> Bel(R): "ab{ab,cde}cd", Dur: 7 -> -> a _ b _ a _ _ b _ _ c _ d _ -> c _ d _ e _ - -and: - -> > bel_ascii_pp "{a{bc,def},ghijk}" -> -> Bel(R): "{a{bc,def},ghijk}", Dur: 5 -> -> a _ _ _ _ _ _ _ _ _ b _ _ _ _ _ _ _ _ _ _ _ _ _ _ c _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> d _ _ _ _ _ _ _ _ _ e _ _ _ _ _ _ _ _ _ f _ _ _ _ _ _ _ _ _ -> g _ _ _ _ _ _ _ h _ _ _ _ _ _ _ i _ _ _ _ _ _ _ j _ _ _ _ _ _ _ k _ _ _ _ _ _ _ - -The /Bel/ notation allows /n/-ary parallel structures, -ie. @{a_bcd_e,a_f_gh_,ji_a_i_}@ (Bel 1992, p.29), however /Bel(R)/ -allows only binary structures. The parallel interpretation rules are -associative: - -> > bel_ascii_pp "{a_bcd_e,{a_f_gh_,ji_a_i_}}" -> -> Bel(R): "{a_bcd_e,{a_f_gh_,ji_a_i_}}", Dur: 7 -> -> a _ b c d _ e -> a _ f _ g h _ -> j i _ a _ i _ - -/Bel(R)/ does allow unary parallel structures (see 'Iso'), which can -be used to /isolate/ tempo changes: - -> > bel_ascii_pp "ab{*2cd}ef{*2/3gh}ij" -> -> Bel(R): "ab{*2cd}ef{*2/3gh}ij", Dur: 10 -> -> a _ b _ c d e _ f _ g _ _ h _ _ i _ j _ - -Patterns with tempo indications have completely different meanings in -/Bel/ and /Bel(R)/, though in both cases parallel nodes delimit the -scope of tempo markings. - -/Bel(R)/ replaces the @\/n@ notation for explicit tempo marks with a -@*n@ notation to indicate a tempo multiplier, and a set of bracketing -notations to specify interpretation rules for parallel (concurrent) -temporal structures. - -The tempo indication @\/1@ in the expression @ab{\/1ab,cde}cd@ -(Bel 1990, p.24) requires that the inner @ab@ have the same tempo as -the outer @ab@, which is implicitly @\/1@. Setting the tempo of one -part of a parallel structure requires assigning a tempo to the other -part in order that the two parts have equal duration. Here the tempo -assigned to @cde@ is @\/1.5@, but since fractional tempi are not -allowed the expression is re-written as @\/2ab{\/2ab,\/3cde}\/2cd@. - -Importantly the explicit tempo indications make it possible to write -syntactically correct expressions in /Bel/ that do not have a coherent -interpretation, ie. @{\/1ab,\/1cde}@. Determining if a coherent set -of tempos can be assigned, and assigning these tempos, is the object -of the interpretation system. - -In comparison, all syntactically valid /Bel(R)/ strings have an -interpretation. The expression @{*1ab,*1cde}@ is trivially equal to -@{ab,cde}@, and tempo marks in parallel parts do not interact: - -> > bel_ascii_pp "{a*2b,*3c/2d/3e}" -> -> Bel(R): "{a*2b,*3c*1/2d*1/3e}", Dur: 3 -> -> a _ _ _ _ _ b _ _ -> c d _ e _ _ _ _ _ - -Here @a@ is twice the duration of @b@, and @e@ is three times the -duration of @d@, which is twice the duration of @c@ (in /Bel(R)/ @\/n@ -is equivalent to @*1\/n@). The duration of any /Bel(R)/ expression -can be calculated directly, given an initial 'Tempo': - -> bel_dur 1 (bel_char_parse "a*2b") == 3/2 -> bel_dur 1 (bel_char_parse "*3c/2d/3e") == 3 - -Therefore in the composite expression the left part is slowed by a -factor of two to align with the right part. - -The /Bel/ string @ab{\/1ab,cde}cd@ can be re-written in /Bel(R)/ as -either @ab~{ab,cde}cd@ or @ab(ab,cde)cd@. The absolute tempo -indication is replaced by notations giving alternate modes of -interpretation for the parallel structure. - -In the first case the @~@ indicates the /opposite/ of the normal rule -for parallel nodes. The normal rule is the same as for /Bel/ and is -that the duration of the whole is equal to duration of the longer of -the two parts. The @~@ inverts this so that the whole has the -duration of the shorter of the two parts, and the longer part is -scaled to have equal duration. - -In the second case the parentheses @()@ replacing the braces @{}@ -indicates that the duration of the whole is equal to the duration of -the left side, and that the right is to be scaled. Similarly, a @~@ -preceding parentheses indicates the duration of the whole should be -the duration of the right side, and the left scaled. - -> > bel_ascii_pp "ab~{ab,cde}cd" -> -> Bel(R): "ab~{ab,cde}cd", Dur: 6 -> -> a _ _ b _ _ a _ _ b _ _ c _ _ d _ _ -> c _ d _ e _ - -There is one other parallel mode that has no equivalent in /Bel/ -notation. It is a mode that does not scale either part, leaving a -/hole/ at the end of the shorter part, and is indicated by square -brackets: - -> > bel_ascii_pp "ab[ab,cde]cd" -> -> Bel(R): "ab[ab,cde]cd", Dur: 7 -> -> a b a b c d -> c d e - -The /Bel/ string @\/2abc\/3de@ (Bel 1992, p.53) can be written as -@*2abc*1/2*3de@, or equivalently as @*2abc*3/2de@: - -> > bel_ascii_pp "*2abc*3/2de" -> -> Bel(R): "*2abc*3/2de", Dur: 13/6 -> -> a _ _ b _ _ c _ _ d _ e _ - -It can also be written using the shorthand notation for rest -sequences, where an integer /n/ indicates a sequence of /n/ rests, as: - -> > bel_ascii_pp "(9,abc)(4,de)" -> -> Bel(R): "(---------,abc)(----,de)", Dur: 13 -> -> - - - - - - - - - - - - - -> a _ _ b _ _ c _ _ d _ e _ - -In the /Bel/ string @{ab{/3abc,de},fghijk}@ (Bel 1992, p.20) the tempo -indication does not change the inter-relation of the parts but rather -scales the parallel node altogether, and can be re-written in /Bel(R)/ -notation as: - -> > bel_ascii_pp "{ab*3{abc,de},fghijk}" -> -> Bel(R): "{ab*3{abc,de},fghijk}", Dur: 6 -> -> a _ _ _ _ _ b _ _ _ _ _ a _ b _ c _ -> d _ _ e _ _ -> f _ _ g _ _ h _ _ i _ _ j _ _ k _ _ - -Curiously the following example (Bel 1990, p. 24) does not correspond -to the phase diagram given: - -> > bel_ascii_pp "{i{ab,cde},jk}" -> -> Bel(R): "{i{ab,cde},jk}", Dur: 4 -> -> i _ a _ _ b _ _ -> c _ d _ e _ -> j _ _ _ k _ _ _ - -The paper assigns tempi of @\/6@ to both @i@ and @ab@, which in -/Bel(R)/ could be written: - -> > bel_ascii_pp "{i~{ab,cde},jk}" -> -> Bel(R): "{i~{ab,cde},jk}", Dur: 3 -> -> i _ _ _ _ _ a _ _ _ _ _ b _ _ _ _ _ -> c _ _ _ d _ _ _ e _ _ _ -> j _ _ _ _ _ _ _ _ k _ _ _ _ _ _ _ _ - +For details see . -} module Music.Theory.Time.Bel1990.R where @@ -197,18 +20,18 @@ import Data.Function {- base -} import Data.List {- base -} import Data.Ratio {- base -} -import qualified Text.ParserCombinators.Parsec as P {- parsec -} +import qualified Text.Parsec as P {- parsec -} + import qualified Music.Theory.List as T -import qualified Music.Theory.Math 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) @@ -220,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 @@ -228,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 @@ -264,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 @@ -310,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) @@ -334,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] @@ -359,7 +227,7 @@ -- | Merge two ascending 'L_Bel'. lbel_merge :: L_Bel a -> L_Bel a -> L_Bel a -lbel_merge = T.merge_by (compare `on` lterm_time) +lbel_merge = T.merge_on lterm_time -- | Set of unique 'Tempo' at 'L_Bel'. lbel_tempi :: L_Bel a -> [Tempo] @@ -369,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') @@ -391,14 +266,14 @@ -- | Unique 'Voice's at 'L_Bel'. lbel_voices :: L_Bel a -> [Voice] lbel_voices = - sortBy (compare `on` reverse) . + sortOn reverse . nub . map (\((_,_,v),_) -> voice_normalise v) -- | The duration of 'L_Bel'. lbel_duration :: L_Bel a -> Time lbel_duration b = - let l = last (groupBy ((==) `on` lterm_time) b) + let l = last (T.group_on lterm_time b) in maximum (map (\((st,tm,_),_) -> st + recip tm) l) -- | Locate an 'L_Term' that is active at the indicated 'Time' and in @@ -448,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 @@ -488,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 @@ -499,87 +376,85 @@ -- * 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_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 positive 'Integer'. +-- | Parse non-negative 'Integer'. -- --- > P.parse p_integer "" "3" -p_integer :: P Integer -p_integer = liftM read (P.many1 P.digit) +-- > P.parse p_non_negative_integer "" "3" +p_non_negative_integer :: T.P Integer +p_non_negative_integer = fmap read (P.many1 P.digit) --- | Parse positive 'Rational'. +-- | Parse non-negative 'Rational'. -- --- > P.parse (p_rational `P.sepBy` (P.char ',')) "" "3%5,2/3" -p_rational :: P Rational -p_rational = do - n <- p_integer +-- > P.parse (p_non_negative_rational `P.sepBy` (P.char ',')) "" "3%5,2/3" +p_non_negative_rational :: T.P Rational +p_non_negative_rational = do + n <- p_non_negative_integer _ <- P.oneOf "%/" - d <- p_integer + d <- p_non_negative_integer return (n % d) --- | Parse positive 'Double'. +-- | Parse non-negative 'Double'. -- --- > P.parse p_double "" "3.5" --- > P.parse (p_double `P.sepBy` (P.char ',')) "" "3.5,7.2,1.0" -p_double :: P Double -p_double = do +-- > 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 :: T.P Double +p_non_negative_double = do a <- P.many1 P.digit _ <- P.char '.' b <- P.many1 P.digit return (read (a ++ "." ++ b)) --- | Parse positive number as 'Rational'. +-- | Parse non-negative number as 'Rational'. -- --- > P.parse (p_number `P.sepBy` (P.char ',')) "" "7%2,3.5,3" -p_number :: P Rational -p_number = P.choice [P.try p_rational - ,P.try (liftM toRational p_double) - ,P.try (liftM toRational p_integer)] +-- > P.parse (p_non_negative_number `P.sepBy` (P.char ',')) "" "7%2,3.5,3" +p_non_negative_number :: T.P Rational +p_non_negative_number = + P.choice [P.try p_non_negative_rational + ,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_number + n <- p_non_negative_number let n' = case op of '*' -> n '/' -> recip n @@ -587,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'. diff --git a/Music/Theory/Time/Duration.hs b/Music/Theory/Time/Duration.hs deleted file mode 100644 --- a/Music/Theory/Time/Duration.hs +++ /dev/null @@ -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') diff --git a/Music/Theory/Time/KeyKit.hs b/Music/Theory/Time/KeyKit.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Time/KeyKit.hs @@ -0,0 +1,236 @@ +{- | A sequence structure, courtesy . + +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) diff --git a/Music/Theory/Time/KeyKit/Basic.hs b/Music/Theory/Time/KeyKit/Basic.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Time/KeyKit/Basic.hs @@ -0,0 +1,52 @@ +-- | Translations of some functions from +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 diff --git a/Music/Theory/Time/KeyKit/Parser.hs b/Music/Theory/Time/KeyKit/Parser.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Time/KeyKit/Parser.hs @@ -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 diff --git a/Music/Theory/Time/Notation.hs b/Music/Theory/Time/Notation.hs deleted file mode 100644 --- a/Music/Theory/Time/Notation.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Music.Theory.Time.Notation where - -import Text.Printf {- base -} - --- | Fractional seconds. -type FSEC = Double - --- | Minutes, seconds as @(min,sec)@ -type MINSEC = (Int,Int) - --- | Minutes, seconds, centi-seconds as @(min,sec,csec)@ -type MINCSEC = (Int,Int,Int) - --- | Fractional seconds to @(min,sec)@. --- --- > map fsec_to_minsec [59.49,60,60.51] == [(0,59),(1,0),(1,1)] -fsec_to_minsec :: FSEC -> MINSEC -fsec_to_minsec tm = round tm `divMod` 60 - --- | 'MINSEC' pretty printer. --- --- > map (minsec_pp . fsec_to_minsec) [59,61] == ["00:59","01:01"] -minsec_pp :: MINSEC -> String -minsec_pp (m,s) = printf "%02d:%02d" m s - --- | Fractional seconds to @(min,sec,csec)@. --- --- > map fsec_to_mincsec [1,1.5,4/3] == [(0,1,0),(0,1,50),(0,1,33)] -fsec_to_mincsec :: FSEC -> MINCSEC -fsec_to_mincsec tm = - let tm' = floor tm - (m,s) = tm' `divMod` 60 - cs = round ((tm - fromIntegral tm') * 100) - in (m,s,cs) - --- | 'MINCSEC' pretty printer. --- --- > map (mincsec_pp . fsec_to_mincsec) [1,4/3] == ["00:01.00","00:01.33"] -mincsec_pp :: MINCSEC -> String -mincsec_pp (m,s,cs) = printf "%02d:%02d.%02d" m s cs - -span_pp :: (t -> String) -> (t,t) -> String -span_pp f (t1,t2) = concat [f t1," - ",f t2] diff --git a/Music/Theory/Time/Seq.hs b/Music/Theory/Time/Seq.hs --- a/Music/Theory/Time/Seq.hs +++ b/Music/Theory/Time/Seq.hs @@ -1,60 +1,74 @@ -- | Basic temporal sequence functions. module Music.Theory.Time.Seq where +import Data.Bifunctor {- base -} import Data.Function {- base -} import Data.List {- base -} -import qualified Data.List.Ordered as O {- data-ordlist -} -import qualified Data.Map as M {- containers -} import Data.Maybe {- base -} -import Data.Monoid {- base -} import Data.Ratio {- base -} import Safe {- safe -} -import Music.Theory.Function {- hmt -} -import qualified Music.Theory.List as T {- hmt -} -import qualified Music.Theory.Math as T {- hmt -} -import qualified Music.Theory.Tuple as T {- hmt -} +import qualified Data.List.Ordered as O {- data-ordlist -} +import qualified Data.Map as Map {- containers -} +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 -- | Sequence of elements with uniform duration. type Useq t a = (t,[a]) --- | Duration sequence. The duration is the /forward/ duration of the --- value, if it has other durations they must be encoded at /a/. +-- | Duration sequence. +-- /t/ indicates the /forward/ duration of the value, ie. the interval to the next value. +-- If there are other durations they must be encoded at /a/. +-- If the sequence does not begin at time zero there must be an /empty/ value for /a/. type Dseq t a = [(t,a)] --- | Inter-offset sequence. The duration is the interval /before/ the --- value. To indicate the duration of the final value /a/ must have --- an /nil/ (end of sequence) value. +-- | Inter-offset sequence. +-- /t/ is the interval /before/ the value. +-- Duration can be encoded at /a/, or if implicit /a/ must include an end of sequence value. type Iseq t a = [(t,a)] --- | Pattern sequence. The duration is a triple of /logical/, --- /sounding/ and /forward/ durations. +-- | Pattern sequence. +-- The duration is a triple of /logical/, /sounding/ and /forward/ durations. +-- 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. To express holes /a/ must have a /empty/ --- value. To indicate the duration of the final value /a/ must have --- an /nil/ (end of sequence) value. +-- | Time-point sequence. +-- /t/ is the start time of the value. +-- To express holes /a/ must have an /empty/ value. +-- Duration can be encoded at /a/, or if implicit /a/ must include an end of sequence value. type Tseq t a = [(t,a)] --- | Window sequence. The temporal field is (/time/,/duration/). --- Holes exist where @t(n) + d(n)@ '<' @t(n+1)@. Overlaps exist where --- the same relation is '>'. +-- | Window sequence. +-- /t/ is a duple of /start-time/ and /duration/. +-- Holes exist where /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 --- | Given functions for deriving start and end times calculate time --- span of sequence. +-- | Given functions for deriving start and end times calculate time span of sequence. +-- Requires sequence be finite. -- -- > seq_tspan id id [] == (0,0) -- > seq_tspan id id (zip [0..9] ['a'..]) == (0,9) @@ -63,30 +77,49 @@ (maybe 0 (st . fst) (headMay sq) ,maybe 0 (et . fst) (lastMay sq)) +-- | 'seq_tspan' for 'Tseq'. tseq_tspan :: Num t => Tseq t a -> (t,t) tseq_tspan = seq_tspan id id +-- | 'seq_tspan' for 'Wseq'. wseq_tspan :: Num t => Wseq t a -> (t,t) wseq_tspan = seq_tspan fst (uncurry (+)) +-- | Start time of sequence. +-- +-- > wseq_start [((1,2),'a')] == 1 +-- > wseq_start [] == 0 +wseq_start :: Num t => Wseq t a -> t +wseq_start = fst . wseq_tspan + +-- | End time of sequence. +-- +-- > wseq_end [((1,2),'a')] == 3 +-- > wseq_end (useq_to_wseq 0 (1,"linear")) == 6 +wseq_end :: Num t => Wseq t a -> t +wseq_end = snd . wseq_tspan + -- * Duration +-- | Sum durations at 'Dseq', result is the end time of the last element. dseq_dur :: Num t => Dseq t a -> t dseq_dur = sum . map fst +-- | Sum durations at 'Iseq', result is the start time of the last element. iseq_dur :: Num t => Iseq t a -> t iseq_dur = sum . map fst +-- | Sum durations at 'Pseq', result is the end time of the last element. pseq_dur :: Num t => Pseq t a -> t pseq_dur = sum . map (T.t3_third . fst) --- | The interval of 'tseq_tspan'. +-- | The interval of 'tseq_tspan', ie. from the start of the first element to the start of the last. -- -- > tseq_dur (zip [0..] "abcde|") == 5 tseq_dur :: Num t => Tseq t a -> t tseq_dur = uncurry subtract . tseq_tspan --- | The interval of 'wseq_tspan'. +-- | The interval of 'wseq_tspan', ie. from the start of the first element to the end of the last. -- -- > wseq_dur (zip (zip [0..] (repeat 2)) "abcde") == 6 wseq_dur :: Num t => Wseq t a -> t @@ -94,23 +127,62 @@ -- * Window --- | Keep only elements in the indicated temporal window. +-- | Prefix of sequence where the start time precedes or is at the indicated time. +wseq_until :: Ord t => t -> Wseq t a -> Wseq t a +wseq_until tm = takeWhile (\((t0,_),_) -> t0 <= tm) + +-- | Keep only elements that are entirely contained within the indicated +-- temporal window, which is inclusive at the left & right +-- edges, ie. [t0,t1]. Halts processing at end of window. -- -- > let r = [((5,1),'e'),((6,1),'f'),((7,1),'g'),((8,1),'h')] --- > in wseq_twindow (5,9) (zip (zip [1..10] (repeat 1)) ['a'..]) == r +-- > wseq_twindow (5,9) (zip (zip [1..] (repeat 1)) ['a'..]) == r +-- +-- > wseq_twindow (1,2) [((1,1),'a'),((1,2),'b')] == [((1,1),'a')] wseq_twindow :: (Num t, Ord t) => (t,t) -> Wseq t a -> Wseq t a wseq_twindow (w0,w1) = let f (st,du) = w0 <= st && (st + du) <= w1 - in wseq_tfilter f + in wseq_tfilter f . wseq_until w1 +-- | Select nodes that are active at indicated time, comparison is +-- inclusive at left and exclusive at right. Halts processing at end +-- of window. +-- +-- > let sq = [((1,1),'a'),((1,2),'b')] +-- > map (wseq_at sq) [1,2] == [sq,[((1,2),'b')]] +-- +-- > wseq_at (zip (zip [1..] (repeat 1)) ['a'..]) 3 == [((3,1),'c')] +wseq_at :: (Num t,Ord t) => Wseq t a -> t -> Wseq t a +wseq_at sq tm = + let sel ((t0,t1),_) = t0 <= tm && tm < (t0 + t1) + end ((t0,_),_) = t0 <= tm + in filter sel (takeWhile end sq) + +-- | Select nodes that are active within the indicated window, comparison is +-- inclusive at left and exclusive at right. Halts processing at end +-- of window. +-- +-- > let sq = [((0,2),'a'),((0,4),'b'),((2,4),'c')] +-- > wseq_at_window sq (1,3) == sq +-- +-- > wseq_at_window (zip (zip [1..] (repeat 1)) ['a'..]) (3,4) == [((3,1),'c'),((4,1),'d')] +wseq_at_window :: (Num t, Ord t) => Wseq t a -> (t,t) -> Wseq t a +wseq_at_window sq (w0,w1) = + let f (t0,t1) t = t0 <= t && t < t1 + g (st,du) = let w = (st,st + du) in f w w0 || f w w1 + in wseq_tfilter g (wseq_until w1 sq) + -- * Append +-- | Type specialised '++' dseq_append :: Dseq t a -> Dseq t a -> Dseq t a dseq_append = (++) +-- | Type specialised '++' iseq_append :: Iseq t a -> Iseq t a -> Iseq t a iseq_append = (++) +-- | Type specialised '++' pseq_append :: Pseq t a -> Pseq t a -> Pseq t a pseq_append = (++) @@ -140,11 +212,28 @@ g (t,p) (_,q) = (t,f p q) in T.merge_by_resolve g cmp +-- | Compare first by start time, then by duration. +w_compare :: Ord t => ((t,t),a) -> ((t,t),a) -> Ordering +w_compare ((t1,d1),_) ((t2,d2),_) = + case compare t1 t2 of + EQ -> compare d1 d2 + r -> r + +-- | Merge considering only start times. wseq_merge :: Ord t => Wseq t a -> Wseq t a -> Wseq t a wseq_merge = O.mergeBy (compare `on` (fst . fst)) +-- | Merge set considering both start times & durations. +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. tseq_lookup_window_by :: (t -> t -> Ordering) -> Tseq t e -> t -> (Maybe (t,e),Maybe (t,e)) tseq_lookup_window_by cmp = let recur l sq t = @@ -173,13 +262,17 @@ -- * Lseq -data Interpolation_T = None | Linear - deriving (Eq,Enum,Show) +-- | Iterpolation type enumeration. +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 @@ -208,41 +301,45 @@ -- * Map, Filter, Find -seq_tmap :: (t -> t') -> [(t,a)] -> [(t',a)] -seq_tmap f = map (\(p,q) -> (f p,q)) +-- | 'map' over time (/t/) data. +seq_tmap :: (t1 -> t2) -> [(t1,a)] -> [(t2,a)] +seq_tmap f = map (first f) -seq_map :: (b -> c) -> [(a,b)] -> [(a,c)] -seq_map f = map (\(p,q) -> (p,f q)) +-- | 'map' over element (/e/) data. +seq_map :: (e1 -> e2) -> [(t,e1)] -> [(t,e2)] +seq_map f = map (second f) --- | Map /t/ and /e/ simultaneously. -seq_bimap :: (t -> t') -> (e -> e') -> [(t,e)] -> [(t',e')] -seq_bimap f g = map (\(p,q) -> (f p,g q)) +-- | 'map' /t/ and /e/ simultaneously. +-- +-- > seq_bimap negate succ (zip [1..5] [0..4]) == [(-1,1),(-2,2),(-3,3),(-4,4),(-5,5)] +seq_bimap :: (t1 -> t2) -> (e1 -> e2) -> [(t1,e1)] -> [(t2,e2)] +seq_bimap f = map . bimap f +-- | 'filter' over time (/t/) data. seq_tfilter :: (t -> Bool) -> [(t,a)] -> [(t,a)] seq_tfilter f = filter (f . fst) +-- | 'filter' over element (/e/) data. seq_filter :: (b -> Bool) -> [(a,b)] -> [(a,b)] seq_filter f = filter (f . snd) -seq_find :: (a -> Bool) -> [(t,a)] -> Maybe (t,a) -seq_find f = let f' (_,a) = f a in find f' +-- | 'find' over element (/e/) data. +seq_find :: (e -> Bool) -> [(t,e)] -> Maybe (t,e) +seq_find f = find (f . snd) -- * Maybe -- | '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'. seq_cat_maybes :: [(t,Maybe q)] -> [(t,q)] seq_cat_maybes = seq_map_maybe id --- | If value is unchanged, according to /f/, replace with 'Nothing'. --- --- > let r = [(1,'s'),(2,'t'),(4,'r'),(6,'i'),(7,'n'),(9,'g')] --- > in seq_cat_maybes (seq_changed_by (==) (zip [1..] "sttrrinng")) == r +-- | If value is unchanged at subsequent entry, according to /f/, replace with 'Nothing'. seq_changed_by :: (a -> a -> Bool) -> [(t,a)] -> [(t,Maybe a)] seq_changed_by f l = let recur z sq = @@ -256,6 +353,9 @@ (t,e) : l' -> (t,Just e) : recur e l' -- | 'seq_changed_by' '=='. +-- +-- > let r = [(1,'s'),(2,'t'),(4,'r'),(6,'i'),(7,'n'),(9,'g')] +-- > seq_cat_maybes (seq_changed (zip [1..] "sttrrinng")) == r seq_changed :: Eq a => [(t,a)] -> [(t,Maybe a)] seq_changed = seq_changed_by (==) @@ -263,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 = let g (t,d) = (f t,d) in seq_tmap g +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 = let g (t,d) = (t,f d) in seq_tmap g +wseq_tmap_dur f = seq_tmap (second f) -- * Partition @@ -275,21 +375,22 @@ -- a sequence into voices. seq_partition :: Ord v => (a -> v) -> [(t,a)] -> [(v,[(t,a)])] seq_partition voice sq = - let assign m (t,a) = M.insertWith (++) (voice a) [(t,a)] m - from_map = sortBy (compare `on` fst) . - map (\(v,l) -> (v,reverse l)) . - M.toList - in from_map (foldl assign M.empty sq) + let assign m (t,a) = Map.insertWith (++) (voice a) [(t,a)] m + from_map = sortOn fst . + map (second reverse) . + Map.toList + in from_map (foldl assign Map.empty sq) -- | Type specialised 'seq_partition'. -- --- > let {p = zip [0,1,3,5] (zip (repeat 0) "abcd") --- > ;q = zip [2,4,6,7] (zip (repeat 1) "ABCD") --- > ;sq = tseq_merge p q} --- > in tseq_partition fst sq == [(0,p),(1,q)] +-- > let p = zip [0,1,3,5] (zip (repeat 0) "abcd") +-- > let q = zip [2,4,6,7] (zip (repeat 1) "ABCD") +-- > let sq = tseq_merge p q +-- > tseq_partition fst sq == [(0,p),(1,q)] tseq_partition :: Ord v => (a -> v) -> Tseq t a -> [(v,Tseq t a)] tseq_partition = seq_partition +-- | Type specialised 'seq_partition'. wseq_partition :: Ord v => (a -> v) -> Wseq t a -> [(v,Wseq t a)] wseq_partition = seq_partition @@ -317,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')] --- > in 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 @@ -336,12 +438,12 @@ -- 'dseq_coalesce' where the /join/ function is 'const'. The -- implementation is simpler and non-recursive. -- --- > let {d = useq_to_dseq (1,"abbcccdde") --- > ;r = dseq_coalesce (==) const d} --- > in dseq_coalesce' (==) d == r +-- > let d = useq_to_dseq (1,"abbcccdde") +-- > let r = dseq_coalesce (==) const d +-- > dseq_coalesce' (==) d == r dseq_coalesce' :: Num t => (a -> a -> Bool) -> Dseq t a -> Dseq t a dseq_coalesce' eq = - let f l = let (t,e:_) = unzip l in (sum t,e) + 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 @@ -358,6 +460,7 @@ tseq_tcoalesce :: Eq t => (a -> a -> a) -> Tseq t a -> Tseq t a tseq_tcoalesce = seq_tcoalesce (==) +-- | Type specialised 'seq_tcoalesce'. wseq_tcoalesce :: ((t,t) -> (t,t) -> Bool) -> (a -> a -> a) -> Wseq t a -> Wseq t a wseq_tcoalesce = seq_tcoalesce @@ -366,7 +469,7 @@ -- | Post-process 'groupBy' of /cmp/ 'on' 'fst'. -- -- > let r = [(0,"a"),(1,"bc"),(2,"de"),(3,"f")] --- > in group_f (==) (zip [0,1,1,2,2,3] ['a'..]) == r +-- > group_f (==) (zip [0,1,1,2,2,3] ['a'..]) == r group_f :: (Eq t,Num t) => (t -> t -> Bool) -> [(t,a)] -> [(t,[a])] group_f cmp = let f l = let (t,a) = unzip l @@ -378,23 +481,27 @@ -- | Group values at equal time points. -- -- > let r = [(0,"a"),(1,"bc"),(2,"de"),(3,"f")] --- > in tseq_group (zip [0,1,1,2,2,3] ['a'..]) == r +-- > tseq_group (zip [0,1,1,2,2,3] ['a'..]) == r +-- +-- > tseq_group [(1,'a'),(1,'b')] == [(1,"ab")] +-- > tseq_group [(1,'a'),(2,'b'),(2,'c')] == [(1,"a"),(2,"bc")] tseq_group :: (Eq t,Num t) => Tseq t a -> Tseq t [a] tseq_group = group_f (==) -- | Group values where the inter-offset time is @0@ to the left. -- -- > let r = [(0,"a"),(1,"bcd"),(1,"ef")] --- > in iseq_group (zip [0,1,0,0,1,0] ['a'..]) == r +-- > iseq_group (zip [0,1,0,0,1,0] ['a'..]) == r iseq_group :: (Eq t,Num t) => Iseq t a -> Iseq t [a] iseq_group = group_f (\_ d -> d == 0) -- * Fill -- | Set durations so that there are no gaps or overlaps. +-- For entries with the same start time this leads to zero durations. -- --- > let r = wseq_zip [0,3,5] [3,2,1] "abc" --- > in wseq_fill_dur (wseq_zip [0,3,5] [2,1,1] "abc") == r +-- > let r = wseq_zip [0,3,3,5] [3,0,2,1] "abcd" +-- > wseq_fill_dur (wseq_zip [0,3,3,5] [2,1,2,1] "abcd") == r wseq_fill_dur :: Num t => Wseq t a -> Wseq t a wseq_fill_dur l = let f (((t1,_),e),((t2,_),_)) = ((t1,t2-t1),e) @@ -412,6 +519,10 @@ t_f n = T.rational_whole_err (n * fromIntegral m) in map (dseq_tmap t_f) sq +-- | End-time of sequence (ie. sum of durations). +dseq_end :: Num t => Dseq t a -> t +dseq_end = sum . map fst + -- * Tseq -- | Given a a default value, a 'Tseq' /sq/ and a list of time-points @@ -430,127 +541,284 @@ EQ -> (sq_t,sq_e) : tseq_latch sq_e sq' t' GT -> (t0,def) : tseq_latch def sq t' +-- | End-time of sequence (ie. time of last event). +tseq_end :: Tseq t a -> t +tseq_end = fst . last + +-- | Append the value /nil/ at /n/ seconds after the end of the sequence. +tseq_add_nil_after :: Num t => a -> t -> Tseq t a -> Tseq t a +tseq_add_nil_after nil n sq = sq ++ [(tseq_end sq + n,nil)] + -- * Wseq --- | Transform 'Wseq' to 'Tseq' by discaring durations. +-- | Sort 'Wseq' by start time, 'Wseq' ought never to be out of +-- order. +-- +-- > wseq_sort [((3,1),'a'),((1,3),'b')] == [((1,3),'b'),((3,1),'a')] +wseq_sort :: Ord t => Wseq t a -> Wseq t a +wseq_sort = sortBy (compare `on` (fst . fst)) + +-- | Transform 'Wseq' to 'Tseq' by discarding durations. wseq_discard_dur :: Wseq t a -> Tseq t a wseq_discard_dur = let f ((t,_),e) = (t,e) in map f --- | Edit durations to ensure that notes don't overlap. If the same --- note is played simultaneously delete shorter note. If a note --- extends into a later note shorten duration (apply /d_fn/ to iot). -wseq_remove_overlaps :: (Eq e,Ord t,Num t) => - (e -> e -> Bool) -> (t -> t) -> - Wseq t e -> Wseq t e -wseq_remove_overlaps eq_fn d_fn = - let go sq = - case sq of - [] -> [] - ((t,d),a):sq' -> - case find (eq_fn a . snd) sq' of - Nothing -> ((t,d),a) : go sq' - Just ((t',d'),a') -> - if t == t' - then if d <= d' - then -- delete LHS - go sq' - else -- delete RHS - ((t,d),a) : - go (delete ((t',d'),a') sq') - else if t' < t + d - then ((t,d_fn (t' - t)),a) : go sq' - else ((t,d),a) : go sq' - in go +-- | Are /e/ equal and do nodes overlap? +-- Nodes are ascending, and so overlap if: +-- 1. they begin at the same time and the first has non-zero duration, or +-- 2. the second begins before the first ends. +wseq_nodes_overlap :: (Ord t,Num t) => (e -> e -> Bool) -> ((t,t),e) -> ((t,t),e) -> Bool +wseq_nodes_overlap eq_f ((t1,d1),a1) ((t2,_d2),a2) = + eq_f a1 a2 && ((t1 == t2 && d1 > 0) || (t2 < (t1 + d1))) +-- | Find first node at /sq/ that overlaps with /e0/, if there is one. +-- Note: this could, but does not, halt early, ie. when t2 > (t1 + d1). +wseq_find_overlap_1 :: (Ord t,Num t) => (e -> e -> Bool) -> ((t,t),e) -> Wseq t e -> Bool +wseq_find_overlap_1 eq_f e0 = isJust . find (wseq_nodes_overlap eq_f e0) + +-- | Determine if sequence has any overlapping equal nodes, stops after finding first instance. +-- +-- > wseq_has_overlaps (==) [] == False +-- > wseq_has_overlaps (==) [((0,1),'x')] +wseq_has_overlaps :: (Ord t, Num t) => (e -> e -> Bool) -> Wseq t e -> Bool +wseq_has_overlaps eq_fn = + let recur sq = + case sq of + [] -> False + e0:sq' -> wseq_find_overlap_1 eq_fn e0 sq' || recur sq' + in recur + +{- | Remove overlaps by deleting any overlapping nodes. + +> let sq = [((0,1),'a'),((0,5),'a'),((1,5),'a'),((3,1),'a')] +> wseq_has_overlaps (==) sq == True +> let sq_rw = wseq_remove_overlaps_rm (==) sq +> sq_rw == [((0,1),'a'),((1,5),'a')] +> wseq_has_overlaps (==) sq_rw +-} +wseq_remove_overlaps_rm :: (Ord t,Num t) => (e -> e -> Bool) -> Wseq t e -> Wseq t e +wseq_remove_overlaps_rm eq_f = + let recur sq = + case sq of + [] -> [] + e0:sq' -> e0 : recur (filter (not . wseq_nodes_overlap eq_f e0) sq') + in recur + +{- | Find first instance of overlap of /e/ at /sq/ and re-write durations so nodes don't overlap. + If equal nodes begin simultaneously delete the shorter node (eithe LHS or RHS). + If a node extends into a later node shorten the initial (LHS) duration (apply /dur_fn/ to iot). +-} +wseq_remove_overlap_rw_1 :: (Ord t,Num t) => + (e -> e -> Bool) -> (t -> t) -> ((t,t),e) -> Wseq t e -> Maybe (Wseq t e) +wseq_remove_overlap_rw_1 eq_f dur_fn ((t,d),a) sq = + let n_eq ((t1,d1),e1) ((t2,d2),e2) = t1 == t2 && d1 == d2 && eq_f e1 e2 + in case find (eq_f a . snd) sq of + Nothing -> Nothing + Just ((t',d'),a') -> + if t == t' + then if d <= d' + then Just sq -- delete LHS + else Just (((t,d),a) : deleteBy n_eq ((t',d'),a') sq) -- delete RHS + else if t' < t + d + then Just (((t,dur_fn (t' - t)),a) : sq) -- truncate LHS + else Nothing + +{- | Run 'wseq_remove_overlap_rw_1' until sequence has no overlaps. + +> let sq = [((0,1),'a'),((0,5),'a'),((1,5),'a'),((3,1),'a')] +> wseq_has_overlaps (==) sq == True +> let sq_rw = wseq_remove_overlaps_rw (==) id sq +> sq_rw == [((0,1),'a'),((1,2),'a'),((3,1),'a')] +> wseq_has_overlaps (==) sq_rw == False + +> import qualified Music.Theory.Array.Csv.Midi.Mnd as T {- hmt -} +> let csv_fn = "/home/rohan/uc/the-center-is-between-us/visitants/csv/midi/air.B.1.csv" +> sq <- T.csv_midi_read_wseq csv_fn :: IO (Wseq Double (T.Event Double)) +> 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 = + let recur sq = + case sq of + [] -> [] + h:sq' -> + case wseq_remove_overlap_rw_1 eq_f dur_fn h sq' of + Nothing -> h : recur sq' + Just sq'' -> recur sq'' + in recur + -- | Unjoin elements (assign equal time stamps to all elements). seq_unjoin :: [(t,[e])] -> [(t,e)] seq_unjoin = let f (t,e) = zip (repeat t) e in concatMap f --- | Type specialised. +-- | Type specialised 'seq_unjoin'. wseq_unjoin :: Wseq t [e] -> Wseq t e wseq_unjoin = seq_unjoin --- * On/Off +-- | Shift (displace) onset times by /i/. +-- +-- > wseq_shift 3 [((1,2),'a')] == [((4,2),'a')] +wseq_shift :: Num t => t -> Wseq t a -> Wseq t a +wseq_shift i = wseq_tmap_st (+ i) --- | Container for values that have /on/ and /off/ modes. -data On_Off a = On a | Off a deriving (Eq,Show) +-- | Shift q to end of p and append. +-- +-- > wseq_append [((1,2),'a')] [((1,2),'b')] == [((1,2),'a'),((4,2),'b')] +wseq_append :: Num t => Wseq t a -> Wseq t a -> Wseq t a +wseq_append p q = p ++ wseq_shift (wseq_end p) q --- | Structural comparison at 'On_Off', 'On' compares less than 'Off'. -cmp_on_off :: On_Off a -> On_Off b -> Ordering -cmp_on_off p q = +-- | 'foldl1' of 'wseq_append' +-- +-- > wseq_concat [[((1,2),'a')],[((1,2),'b')]] == [((1,2),'a'),((4,2),'b')] +wseq_concat :: Num t => [Wseq t a] -> Wseq t a +wseq_concat = foldl1 wseq_append + +-- | Transform sequence to start at time zero. +wseq_zero :: Num t => Wseq t a -> Wseq t a +wseq_zero sq = let t0 = wseq_start sq in wseq_tmap (\(st,du) -> (st - t0,du)) sq + +-- * Begin/End + +-- | Container to mark the /begin/ and /end/ of a value. +data Begin_End a = Begin a | End a deriving (Eq,Show) + +-- | Functor instance. +begin_end_map :: (t -> u) -> Begin_End t -> Begin_End u +begin_end_map f x = + case x of + Begin a -> Begin (f a) + End a -> End (f a) + +instance Functor Begin_End where fmap = begin_end_map + +-- | Structural comparison at 'Begin_End', 'Begin' compares less than 'End'. +cmp_begin_end :: Begin_End a -> Begin_End b -> Ordering +cmp_begin_end p q = case (p,q) of - (On _,Off _) -> LT - (On _,On _) -> EQ - (Off _,Off _) -> EQ - (Off _,On _) -> GT + (Begin _,End _) -> LT + (Begin _,Begin _) -> EQ + (End _,End _) -> EQ + (End _,Begin _) -> GT +--instance Eq t => Ord (Begin_End t) where compare = cmp_begin_end + -- | Translate container types. -either_to_on_off :: Either a a -> On_Off a -either_to_on_off p = +either_to_begin_end :: Either a a -> Begin_End a +either_to_begin_end p = case p of - Left a -> On a - Right a -> Off a + Left a -> Begin a + Right a -> End a -- | Translate container types. -on_off_to_either :: On_Off a -> Either a a -on_off_to_either p = +begin_end_to_either :: Begin_End a -> Either a a +begin_end_to_either p = case p of - On a -> Left a - Off a -> Right a + Begin a -> Left a + End a -> Right a --- | Convert 'Wseq' to 'Tseq' transforming elements to 'On' and 'Off' --- parts. When merging, /off/ elements precede /on/ elements at equal --- times. --- --- > let {sq = [((0,5),'a'),((2,2),'b')] --- > ;r = [(0,On 'a'),(2,On 'b'),(4,Off 'b'),(5,Off 'a')]} --- > in wseq_on_off sq == r --- --- > let {sq = [((0,1),'a'),((1,1),'b'),((2,1),'c')] --- > ;r = [(0,On 'a'),(1,Off 'a') --- > ,(1,On 'b'),(2,Off 'b') --- > ,(2,On 'c'),(3,Off 'c')]} --- > in wseq_on_off sq == r -wseq_on_off :: (Num t, Ord t) => Wseq t a -> Tseq t (On_Off a) -wseq_on_off sq = - let f ((t,d),a) = [(t,On a),(t + d,Off a)] +-- | Equivalent to 'partitionEithers'. +begin_end_partition :: [Begin_End a] -> ([a],[a]) +begin_end_partition = + let f e (p,q) = case e of + Begin x -> (x:p,q) + End x -> (p,x:q) + in foldr f ([],[]) + +-- | Add or delete element from accumulated state given equality function. +begin_end_track_by :: (a -> a -> Bool) -> [a] -> Begin_End a -> [a] +begin_end_track_by eq_f st e = + case e of + Begin x -> x : st + End x -> deleteBy eq_f x st + +-- | 'begin_end_track_by' of '=='. +begin_end_track :: Eq a => [a] -> Begin_End a -> [a] +begin_end_track = begin_end_track_by (==) + +{- | Convert 'Wseq' to 'Tseq' transforming elements to 'Begin_End'. + When merging, /end/ elements precede /begin/ elements at equal times. + +> let sq = [((0,5),'a'),((2,2),'b')] +> let r = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End 'a')] +> wseq_begin_end sq == r + +> let sq = [((0,1),'a'),((1,1),'b'),((2,1),'c')] +> let r = [(0,Begin 'a'),(1,End 'a'),(1,Begin 'b'),(2,End 'b'),(2,Begin 'c'),(3,End 'c')] +> wseq_begin_end sq == r +-} +wseq_begin_end :: (Num t, Ord t) => Wseq t a -> Tseq t (Begin_End a) +wseq_begin_end sq = + let f ((t,d),a) = [(t,Begin a),(t + d,End a)] g l = case l of [] -> [] - e:l' -> tseq_merge_by (T.ordering_invert .: cmp_on_off) e (g l') + e:l' -> tseq_merge_by (\x -> T.ord_invert . cmp_begin_end x) e (g l') in g (map f sq) --- | 'on_off_to_either' of 'wseq_on_off'. -wseq_on_off_either :: (Num t, Ord t) => Wseq t a -> Tseq t (Either a a) -wseq_on_off_either = tseq_map on_off_to_either . wseq_on_off +-- | 'begin_end_to_either' of 'wseq_begin_end'. +wseq_begin_end_either :: (Num t, Ord t) => Wseq t a -> Tseq t (Either a a) +wseq_begin_end_either = tseq_map begin_end_to_either . wseq_begin_end --- | Variant that applies /on/ and /off/ functions to nodes. +-- | Variant that applies /begin/ and /end/ functions to nodes. -- --- > let {sq = [((0,5),'a'),((2,2),'b')] --- > ;r = [(0,'A'),(2,'B'),(4,'b'),(5,'a')]} --- > in wseq_on_off_f Data.Char.toUpper id sq == r -wseq_on_off_f :: (Ord t,Num t) => (a -> b) -> (a -> b) -> Wseq t a -> Tseq t b -wseq_on_off_f f g = tseq_map (either f g) . wseq_on_off_either +-- > let sq = [((0,5),'a'),((2,2),'b')] +-- > let r = [(0,'A'),(2,'B'),(4,'b'),(5,'a')] +-- > wseq_begin_end_f Data.Char.toUpper id sq == r +wseq_begin_end_f :: (Ord t,Num t) => (a -> b) -> (a -> b) -> Wseq t a -> Tseq t b +wseq_begin_end_f f g = tseq_map (either f g) . wseq_begin_end_either --- | Inverse of 'wseq_on_off' given a predicate function for locating --- the /off/ node of an /on/ node. +-- | Generate for each time-point the triple (begin-list,end-list,hold-list). +-- The elements of the end-list have been deleted from the hold list. +tseq_begin_end_accum :: Eq a => Tseq t [Begin_End a] -> Tseq t ([a],[a],[a]) +tseq_begin_end_accum = + let f st (t,x) = + let (b,e) = begin_end_partition x + st' = foldl begin_end_track st x + in (st',(t,(b,e,st \\ e))) + in snd . mapAccumL f [] + +-- | Variant that initially transforms 'Wseq' into non-overlapping begin-end sequence. +-- If the sequence was edited for overlaps this is indicated. +wseq_begin_end_accum :: (Eq e, Ord t, Num t) => Wseq t e -> (Bool, Tseq t ([e],[e],[e])) +wseq_begin_end_accum sq = + let ol = wseq_has_overlaps (==) sq + sq_edit = if ol then wseq_remove_overlaps_rw (==) id sq else sq + a_sq = tseq_begin_end_accum (tseq_group (wseq_begin_end sq_edit)) + in (ol,a_sq) + +tseq_accumulate :: Eq a => Tseq t [Begin_End a] -> Tseq t [a] +tseq_accumulate = + let f st (t,e) = + let g st' = (st',(t,st')) + in g (foldl begin_end_track st e) + in snd . mapAccumL f [] + +-- | The transition sequence of /active/ elements. -- --- > let {sq = [(0,On 'a'),(2,On 'b'),(4,Off 'b'),(5,Off 'a')] --- > ;r = [((0,5),'a'),((2,2),'b')]} --- > in tseq_on_off_to_wseq (==) sq == r -tseq_on_off_to_wseq :: Num t => (a -> a -> Bool) -> Tseq t (On_Off a) -> Wseq t a -tseq_on_off_to_wseq cmp = +-- > let w = [((0,3),'a'),((1,2),'b'),((2,1),'c'),((3,3),'d')] +-- > wseq_accumulate w == [(0,"a"),(1,"ba"),(2,"cba"),(3,"d"),(6,"")] +wseq_accumulate :: (Eq a,Ord t,Num t) => Wseq t a -> Tseq t [a] +wseq_accumulate = tseq_accumulate . tseq_group . wseq_begin_end + +-- | Inverse of 'wseq_begin_end' given a predicate function for locating +-- the /end/ node of a /begin/ node. +-- +-- > let sq = [(0,Begin 'a'),(2,Begin 'b'),(4,End 'b'),(5,End 'a')] +-- > let r = [((0,5),'a'),((2,2),'b')] +-- > tseq_begin_end_to_wseq (==) sq == r +tseq_begin_end_to_wseq :: Num t => (a -> a -> Bool) -> Tseq t (Begin_End a) -> Wseq t a +tseq_begin_end_to_wseq cmp = let cmp' x e = case e of - Off x' -> cmp x x' + End x' -> cmp x x' _ -> False f e r = case seq_find (cmp' e) r of - Nothing -> error "tseq_on_off_to_wseq: no matching off?" + Nothing -> error "tseq_begin_end_to_wseq: no matching end?" Just (t,_) -> t go sq = case sq of [] -> [] - (_,Off _) : sq' -> go sq' - (t,On e) : sq' -> let t' = f e sq' in ((t,t' - t),e) : go sq' + (_,End _) : sq' -> go sq' + (t,Begin e) : sq' -> let t' = f e sq' in ((t,t' - t),e) : go sq' in go -- * Interop @@ -558,35 +826,48 @@ useq_to_dseq :: Useq t a -> Dseq t a useq_to_dseq (t,e) = zip (repeat t) e +useq_to_wseq :: Num t => t -> Useq t a -> Wseq t a +useq_to_wseq t0 = dseq_to_wseq t0 . useq_to_dseq + -- | The conversion requires a start time and a /nil/ value used as an -- /eof/ marker. Productive given indefinite input sequence. -- -- > let r = zip [0,1,3,6,8,9] "abcde|" --- > in dseq_to_tseq 0 '|' (zip [1,2,3,2,1] "abcde") == r +-- > dseq_to_tseq 0 '|' (zip [1,2,3,2,1] "abcde") == r -- --- > let {d = zip [1,2,3,2,1] "abcde" --- > ;r = zip [0,1,3,6,8,9,10] "abcdeab"} --- > in take 7 (dseq_to_tseq 0 undefined (cycle d)) == r +-- > let d = zip [1,2,3,2,1] "abcde" +-- > let r = zip [0,1,3,6,8,9,10] "abcdeab" +-- > take 7 (dseq_to_tseq 0 undefined (cycle d)) == r dseq_to_tseq :: Num t => t -> a -> Dseq t a -> Tseq t a -dseq_to_tseq t0 nil sq = - let (d,a) = unzip sq - t = T.dx_d t0 d - a' = a ++ [nil] - in zip t a' +dseq_to_tseq t0 nil = T.rezip (T.dx_d t0) (T.snoc nil) --- | Variant where the /nil/ is take as the last element of the --- sequence. +-- | Variant where the /nil/ value is taken from the last element of +-- the sequence. -- -- > let r = zip [0,1,3,6,8,9] "abcdee" --- > in dseq_to_tseq_last 0 (zip [1,2,3,2,1] "abcde") == r +-- > dseq_to_tseq_last 0 (zip [1,2,3,2,1] "abcde") == r dseq_to_tseq_last :: Num t => t -> Dseq t a -> Tseq t a dseq_to_tseq_last t0 sq = dseq_to_tseq t0 (snd (last sq)) sq +{- | 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" +-- > iseq_to_tseq 0 (zip [1,2,3,2,1] "abcde") == r +iseq_to_tseq :: Num t => t -> Iseq t a -> Tseq t a +iseq_to_tseq t0 = T.rezip (tail . T.dx_d t0) id + -- | The conversion requires a start time and does not consult the -- /logical/ duration. -- -- > let p = pseq_zip (repeat undefined) (cycle [1,2]) (cycle [1,1,2]) "abcdef" --- > in pseq_to_wseq 0 p == wseq_zip [0,1,2,4,5,6] (cycle [1,2]) "abcdef" +-- > pseq_to_wseq 0 p == wseq_zip [0,1,2,4,5,6] (cycle [1,2]) "abcdef" pseq_to_wseq :: Num t => t -> Pseq t a -> Wseq t a pseq_to_wseq t0 sq = let (p,a) = unzip sq @@ -595,13 +876,14 @@ in wseq_zip t d a -- | The last element of 'Tseq' is required to be an /eof/ marker that --- has no duration and is not represented in the 'Dseq'. +-- has no duration and is not represented in the 'Dseq'. A 'nil' +-- value is required in case the 'Tseq' does not begin at @0@. -- -- > let r = zip [1,2,3,2,1] "abcde" --- > in tseq_to_dseq undefined (zip [0,1,3,6,8,9] "abcde|") == r +-- > tseq_to_dseq undefined (zip [0,1,3,6,8,9] "abcde|") == r -- -- > let r = zip [1,2,3,2,1] "-abcd" --- > in tseq_to_dseq '-' (zip [1,3,6,8,9] "abcd|") == r +-- > tseq_to_dseq '-' (zip [1,3,6,8,9] "abcd|") == r tseq_to_dseq :: (Ord t,Num t) => a -> Tseq t a -> Dseq t a tseq_to_dseq empty sq = let (t,a) = unzip sq @@ -610,16 +892,37 @@ [] -> [] 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 an /dur/ +-- of each value is either derived from the value, if a /dur/ -- function is given, or else the inter-offset time. -- -- > let r = wseq_zip [0,1,3,6,8] [1,2,3,2,1] "abcde" --- > in tseq_to_wseq Nothing (zip [0,1,3,6,8,9] "abcde|") == r +-- > tseq_to_wseq Nothing (zip [0,1,3,6,8,9] "abcde|") == r -- -- > let r = wseq_zip [0,1,3,6,8] (map fromEnum "abcde") "abcde" --- > in tseq_to_wseq (Just fromEnum) (zip [0,1,3,6,8,9] "abcde|") == r +-- > tseq_to_wseq (Just fromEnum) (zip [0,1,3,6,8,9] "abcde|") == r tseq_to_wseq :: Num t => Maybe (a -> t) -> Tseq t a -> Wseq t a tseq_to_wseq dur_f sq = let (t,a) = unzip sq @@ -628,7 +931,21 @@ Nothing -> T.d_dx t in wseq_zip t d a -tseq_to_iseq :: Num t => Tseq t a -> Dseq t 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|" +tseq_to_iseq :: Num t => Tseq t a -> Iseq t a tseq_to_iseq = let recur n p = case p of @@ -639,7 +956,7 @@ -- | Requires start time. -- -- > let r = zip (zip [0,1,3,6,8,9] [1,2,3,2,1]) "abcde" --- > in dseq_to_wseq 0 (zip [1,2,3,2,1] "abcde") == r +-- > dseq_to_wseq 0 (zip [1,2,3,2,1] "abcde") == r dseq_to_wseq :: Num t => t -> Dseq t a -> Wseq t a dseq_to_wseq t0 sq = let (d,a) = unzip sq @@ -651,16 +968,16 @@ -- truncated. -- -- > let w = wseq_zip [0,1,3,6,8,9] [1,2,3,2,1] "abcde" --- > in wseq_to_dseq '-' w == zip [1,2,3,2,1] "abcde" +-- > wseq_to_dseq '-' w == zip [1,2,3,2,1] "abcde" -- -- > let w = wseq_zip [3,10] [6,2] "ab" --- > in wseq_to_dseq '-' w == zip [3,6,1,2] "-a-b" +-- > wseq_to_dseq '-' w == zip [3,6,1,2] "-a-b" -- -- > let w = wseq_zip [0,1] [2,2] "ab" --- > in wseq_to_dseq '-' w == zip [1,2] "ab" +-- > wseq_to_dseq '-' w == zip [1,2] "ab" -- -- > let w = wseq_zip [0,0,0] [2,2,2] "abc" --- > in wseq_to_dseq '-' w == zip [0,0,2] "abc" +-- > wseq_to_dseq '-' w == zip [0,0,2] "abc" wseq_to_dseq :: (Num t,Ord t) => a -> Wseq t a -> Dseq t a wseq_to_dseq empty sq = let f (((st0,d),e),((st1,_),_)) = @@ -675,13 +992,16 @@ ((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 -- the end time of the overall sequence. -- -- > let r = [[(0,'a'),(1,'b'),(3,'c')],[(4,'d'),(7,'e'),(9,'f')]] --- > in dseql_to_tseql 0 [zip [1,2,1] "abc",zip [3,2,1] "def"] == (10,r) +-- > dseql_to_tseql 0 [zip [1,2,1] "abc",zip [3,2,1] "def"] == (10,r) dseql_to_tseql :: Num t => t -> [Dseq t a] -> (t,[Tseq t a]) dseql_to_tseql = let f z dv = @@ -690,8 +1010,33 @@ in (z',zip r el) in mapAccumL f --- * Type specialised map +-- * Cycle +-- | List of cycles of 'Wseq'. +wseq_cycle_ls :: Num t => Wseq t a -> [Wseq t a] +wseq_cycle_ls sq = + let (_,et) = wseq_tspan sq + t_sq = iterate (+ et) 0 + in map (\x -> wseq_tmap (first (+ x)) sq) t_sq + +-- | Only finite 'Wseq' can be cycled, the resulting Wseq is infinite. +-- +-- > take 5 (wseq_cycle [((0,1),'a'),((3,3),'b')]) +wseq_cycle :: Num t => Wseq t a -> Wseq t a +wseq_cycle = concat . wseq_cycle_ls + +-- | Variant cycling only /n/ times. +-- +-- > wseq_cycle_n 3 [((0,1),'a'),((3,3),'b')] +wseq_cycle_n :: Num t => Int -> Wseq t a -> Wseq t a +wseq_cycle_n n = concat . take n . wseq_cycle_ls + +-- | 'wseq_until' of 'wseq_cycle'. +wseq_cycle_until :: (Num t,Ord t) => t -> Wseq t a -> Wseq t a +wseq_cycle_until et = wseq_until et . wseq_cycle + +-- * Type specialised maps + dseq_tmap :: (t -> t') -> Dseq t a -> Dseq t' a dseq_tmap = seq_tmap @@ -758,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 diff --git a/Music/Theory/Time_Signature.hs b/Music/Theory/Time_Signature.hs --- a/Music/Theory/Time_Signature.hs +++ b/Music/Theory/Time_Signature.hs @@ -1,11 +1,12 @@ -- | Time Signatures. module Music.Theory.Time_Signature where +import Data.Function {- base -} import Data.Ratio {- base -} 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. @@ -37,6 +38,7 @@ (1,1) -> [whole_note] (2,2) -> [whole_note] (4,4) -> [whole_note] + (8,8) -> [whole_note] (5,4) -> [whole_note,quarter_note] (3,2) -> [dotted_whole_note] (6,4) -> [dotted_whole_note] @@ -47,22 +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 --- | 'Time_Signature' derived from whole note duration in 'RQ' form. +-- | '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. -- -- > map rq_to_ts [4,3/2,7/4,6] == [(4,4),(3,8),(7,16),(6,4)] -rq_to_ts :: Rational -> Time_Signature +rq_to_ts :: Rq -> Time_Signature rq_to_ts rq = let n = numerator rq d = denominator rq * 4 @@ -74,7 +80,8 @@ -- > ts_divisions (3,8) == [1/2,1/2,1/2] -- > ts_divisions (2,2) == [2,2] -- > ts_divisions (1,1) == [4] -ts_divisions :: Time_Signature -> [RQ] +-- > ts_divisions (7,4) == [1,1,1,1,1,1,1] +ts_divisions :: Time_Signature -> [Rq] ts_divisions (i,j) = let k = fromIntegral i in replicate k (recip (j % 4)) @@ -116,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) @@ -142,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 @@ -151,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 @@ -164,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) @@ -174,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) @@ -191,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)) diff --git a/Music/Theory/Tuning.hs b/Music/Theory/Tuning.hs --- a/Music/Theory/Tuning.hs +++ b/Music/Theory/Tuning.hs @@ -1,304 +1,206 @@ -- | Tuning theory module Music.Theory.Tuning where -import Data.Fixed {- base -} -import Data.List {- base -} -import Data.Maybe {- base -} +import qualified Data.Fixed as Fixed {- base -} import Data.Ratio {- base -} -import Safe {- safe -} -import qualified Music.Theory.Either as T {- hmt -} +import qualified Music.Theory.Function as T {- hmt -} import qualified Music.Theory.List as T {- hmt -} -import qualified Music.Theory.Pitch as T {- hmt -} - --- * Types - --- | An approximation of a ratio. -type Approximate_Ratio = Double - --- | A real valued division of a semi-tone into one hundred parts, and --- hence of the octave into @1200@ parts. -type Cents = Double +import qualified Music.Theory.Math as T {- hmt -} +import qualified Music.Theory.Ord as T {- hmt -} --- | A tuning specified 'Either' as a sequence of exact ratios, or as --- a sequence of possibly inexact 'Cents'. -data Tuning = Tuning {ratios_or_cents :: Either [Rational] [Cents] - ,octave_ratio :: Rational} - deriving (Eq,Show) +-- * Math/Floating --- | Divisions of octave. +-- | Fractional /midi/ note number to cycles per second, given (k0,f0) pair. -- --- > divisions ditone == 12 -divisions :: Tuning -> Int -divisions = either length length . ratios_or_cents - --- | 'Maybe' exact ratios of 'Tuning'. -ratios :: Tuning -> Maybe [Rational] -ratios = T.fromLeft . ratios_or_cents - --- | 'error'ing variant. -ratios_err :: Tuning -> [Rational] -ratios_err = fromMaybe (error "ratios") . ratios - --- | Possibly inexact 'Cents' of tuning. -cents :: Tuning -> [Cents] -cents = either (map ratio_to_cents) id . ratios_or_cents - --- | 'map' 'round' '.' 'cents'. -cents_i :: Integral i => Tuning -> [i] -cents_i = map round . cents +-- > 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))) --- | Variant of 'cents' that includes octave at right. -cents_octave :: Tuning -> [Cents] -cents_octave t = cents t ++ [ratio_to_cents (octave_ratio t)] +-- | '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 = fmidi_to_cps_k0 (69,f0) --- | Convert from interval in cents to frequency ratio. +-- | 'fmidi_to_cps_k0' (69,440) -- --- > map cents_to_ratio [0,701.9550008653874,1200] == [1,3/2,2] -cents_to_ratio :: Floating a => a -> a -cents_to_ratio n = 2 ** (n / 1200) +-- > map fmidi_to_cps [69,69.1] == [440.0,442.5488940698553] +fmidi_to_cps :: Floating a => a -> a +fmidi_to_cps = fmidi_to_cps_k0 (69,440) --- | Possibly inexact 'Approximate_Ratio's of tuning. -approximate_ratios :: Tuning -> [Approximate_Ratio] -approximate_ratios = - either (map approximate_ratio) (map cents_to_ratio) . - ratios_or_cents +-- | /Midi/ note number to cycles per second, given frequency of ISO A4. +midi_to_cps_k0 :: (Integral i,Floating f) => (f,f) -> i -> f +midi_to_cps_k0 o = fmidi_to_cps_k0 o . fromIntegral --- | Cyclic form, taking into consideration 'octave_ratio'. -approximate_ratios_cyclic :: Tuning -> [Approximate_Ratio] -approximate_ratios_cyclic t = - let r = approximate_ratios t - m = realToFrac (octave_ratio t) - g = iterate (* m) 1 - f n = map (* n) r - in concatMap f g +-- | '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_k0 (69,440) --- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents' --- of 'Tuning'. +-- | Convert from interval in cents to frequency ratio. -- --- > let r = [1,17/16,9/8,13/11,5/4,4/3,7/5,3/2,11/7,5/3,16/9,15/8] --- > in reconstructed_ratios 1e-2 werckmeister_iii == Just r -reconstructed_ratios :: Double -> Tuning -> Maybe [Rational] -reconstructed_ratios epsilon = - fmap (map (reconstructed_ratio epsilon)) . - T.fromRight . - ratios_or_cents +-- > map cents_to_fratio [0,701.9550008653874,1200] == [1,3/2,2] +-- > map cents_to_fratio [-1800,1800] -- three octaves about zero +cents_to_fratio :: Floating a => a -> a +cents_to_fratio n = 2 ** (n / 1200) -- | Convert from a 'Floating' ratio to /cents/. -- -- > let r = [0,498,702,1200] --- > in map (round . fratio_to_cents) [1,4/3,3/2,2] == r +-- > map (round . fratio_to_cents) [1,4/3,3/2,2] == r fratio_to_cents :: (Real r,Floating n) => r -> n fratio_to_cents = (1200 *) . logBase 2 . realToFrac --- | Type specialised 'fratio_to_cents'. -approximate_ratio_to_cents :: Approximate_Ratio -> Cents -approximate_ratio_to_cents = fratio_to_cents - --- | Type specialised 'fromRational'. -approximate_ratio :: Rational -> Approximate_Ratio -approximate_ratio = fromRational - --- | 'approximate_ratio_to_cents' '.' 'approximate_ratio'. -ratio_to_cents :: Rational -> Cents -ratio_to_cents = approximate_ratio_to_cents . approximate_ratio - --- | Construct an exact 'Rational' that approximates 'Cents' to within --- /epsilon/. --- --- > map (reconstructed_ratio 1e-5) [0,700,1200] == [1,442/295,2] --- --- > ratio_to_cents (442/295) == 699.9976981706734 -reconstructed_ratio :: Double -> Cents -> Rational -reconstructed_ratio epsilon c = approxRational (cents_to_ratio c) epsilon - -- | Frequency /n/ cents from /f/. -- --- > import Music.Theory.Pitch +-- > import Music.Theory.Pitch {- hmt -} -- > map (cps_shift_cents 440) [-100,100] == map octpc_to_cps [(4,8),(4,10)] cps_shift_cents :: Floating a => a -> a -> a -cps_shift_cents f = (* f) . cents_to_ratio +cps_shift_cents f = (* f) . cents_to_fratio --- | Interval in /cents/ from /p/ to /q/, ie. 'ratio_to_cents' of /p/ --- '/' /q/. +-- | Interval in /cents/ from /p/ to /q/, ie. 'ratio_to_cents' of /p/ '/' /q/. -- --- > cps_difference_cents 440 (octpc_to_cps (5,2)) == 500 +-- > map (round . cps_difference_cents 440) [412,415,octpc_to_cps (5,2)] == [-114,-101,500] -- -- > let abs_dif i j = abs (i - j) --- > in cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9 +-- > cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9 cps_difference_cents :: (Real r,Fractional r,Floating n) => r -> r -> n cps_difference_cents p q = fratio_to_cents (q / p) --- * Commas +-- * Math/Ratio --- | The Syntonic comma. +-- | Convert a (signed) number of octaves difference of given ratio to a ratio. -- --- > syntonic_comma == 81/80 -syntonic_comma :: Rational -syntonic_comma = 81 % 80 +-- > map (oct_diff_to_ratio 2) [-3 .. 3] == [1/8,1/4,1/2,1,2,4,8] +-- > map (oct_diff_to_ratio (9/8)) [-3 .. 3] == [512/729,64/81,8/9,1/1,9/8,81/64,729/512] +oct_diff_to_ratio :: Integral a => Ratio a -> Int -> Ratio a +oct_diff_to_ratio r n = if n >= 0 then T.recur_n n (* r) 1 else T.recur_n (negate n) (/ r) 1 --- | The Pythagorean comma. +-- | 'ratio_to_cents' rounded to nearest multiple of 100, modulo 12. -- --- > pythagorean_comma == 3^12 / 2^19 -pythagorean_comma :: Rational -pythagorean_comma = 531441 / 524288 +-- > map (ratio_to_pc 0) [1,4/3,3/2,2] == [0,5,7,0] +ratio_to_pc :: Int -> Rational -> Int +ratio_to_pc n = T.mod12 . (+ n) . round . (/ 100) . ratio_to_cents --- | Mercators comma. +-- | Fold ratio to lie within an octave, ie. @1@ '<' /n/ '<=' @2@. +-- It is an error for /n/ to be more than one octave outside of this range. -- --- > mercators_comma == 3^53 / 2^84 -mercators_comma :: Rational -mercators_comma = 19383245667680019896796723 / 19342813113834066795298816 +-- > map fold_ratio_to_octave_nonrec [2/3,3/4,4/5,4/7] == [4/3,3/2,8/5,8/7] +fold_ratio_to_octave_nonrec :: (Ord n,Fractional n) => n -> n +fold_ratio_to_octave_nonrec n = + if n >= 1 && n < 2 + then n + else if n >= 2 && n < 4 + then n / 2 + else if n < 1 && n >= (1/2) + then n * 2 + else error "fold_ratio_to_octave_nonrec" --- | Calculate /n/th root of /x/. +-- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@. +-- It is an error if /n/ is less than or equal to zero. -- --- > 12 `nth_root` 2 == twelve_tone_equal_temperament_comma -nth_root :: (Floating a,Eq a) => a -> a -> a -nth_root n x = - let f (_,x0) = (x0, ((n-1)*x0+x/x0**(n-1))/n) - e = uncurry (==) - in fst (until e f (x, x/n)) +-- > map fold_ratio_to_octave_err [2/2,2/3,3/4,4/5,4/7] == [1/1,4/3,3/2,8/5,8/7] +fold_ratio_to_octave_err :: (Ord n,Fractional n) => n -> n +fold_ratio_to_octave_err = + let f n = + if n <= 0 + then error "fold_ratio_to_octave_err?" + else if n >= 2 then f (n / 2) else if n < 1 then f (n * 2) else n + in f --- | 12-tone equal temperament comma (ie. 12th root of 2). +-- | In /n/ is greater than zero, 'fold_ratio_to_octave_err', else 'Nothing'. -- --- > twelve_tone_equal_temperament_comma == 1.0594630943592953 -twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a -twelve_tone_equal_temperament_comma = 12 `nth_root` 2 - --- * Equal temperaments - --- | Make /n/ division equal temperament. -equal_temperament :: Integral n => n -> Tuning -equal_temperament n = - let c = genericTake n [0,1200 / fromIntegral n ..] - in Tuning (Right c) 2 +-- > map fold_ratio_to_octave [0,1] == [Nothing,Just 1] +fold_ratio_to_octave :: (Ord n,Fractional n) => n -> Maybe n +fold_ratio_to_octave n = if n <= 0 then Nothing else Just (fold_ratio_to_octave_err n) --- | 12-tone equal temperament. +-- | The interval between two pitches /p/ and /q/ given as ratio +-- multipliers of a fundamental is /q/ '/' /p/. The classes over such +-- intervals consider the 'fold_ratio_to_octave' of both /p/ to /q/ +-- and /q/ to /p/ and select the minima at the /cmp_f/. -- --- > cents equal_temperament_12 == [0,100..1100] -equal_temperament_12 :: Tuning -equal_temperament_12 = equal_temperament (12::Int) - --- | 19-tone equal temperament. -equal_temperament_19 :: Tuning -equal_temperament_19 = equal_temperament (19::Int) - --- | 31-tone equal temperament. -equal_temperament_31 :: Tuning -equal_temperament_31 = equal_temperament (31::Int) - --- | 53-tone equal temperament. -equal_temperament_53 :: Tuning -equal_temperament_53 = equal_temperament (53::Int) +-- > map (ratio_interval_class_by id) [3/2,5/4] == [4/3,5/4] +ratio_interval_class_by :: (Ord t, Integral i) => (Ratio i -> t) -> Ratio i -> Ratio i +ratio_interval_class_by cmp_f i = + let f = fold_ratio_to_octave_err + in T.min_by cmp_f (f i) (f (recip i)) --- | 72-tone equal temperament. +-- | 'ratio_interval_class_by' 'ratio_nd_sum' -- --- > let r = [0,17,33,50,67,83,100] --- > in take 7 (map round (cents equal_temperament_72)) == r -equal_temperament_72 :: Tuning -equal_temperament_72 = equal_temperament (72::Int) +-- > map ratio_interval_class [2/3,3/2,3/4,4/3] == [3/2,3/2,3/2,3/2] +-- > map ratio_interval_class [7/6,12/7] == [7/6,7/6] +ratio_interval_class :: Integral i => Ratio i -> Ratio i +ratio_interval_class = ratio_interval_class_by T.ratio_nd_sum --- * Harmonic series +-- * Types --- | Raise or lower the frequency /q/ by octaves until it is in the --- octave starting at /p/. --- --- > fold_cps_to_octave_of 55 392 == 98 -fold_cps_to_octave_of :: (Ord a, Fractional a) => a -> a -> a -fold_cps_to_octave_of p = - let f q = if q > p * 2 then f (q / 2) else if q < p then f (q * 2) else q - in f +-- | An approximation of a ratio. +type Approximate_Ratio = Double --- | Harmonic series on /n/. -harmonic_series_cps :: (Num t, Enum t) => t -> [t] -harmonic_series_cps n = [n,n * 2 ..] +-- | Type specialised 'fromRational'. +approximate_ratio :: Rational -> Approximate_Ratio +approximate_ratio = fromRational --- | /n/ elements of 'harmonic_series_cps'. --- --- > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935] --- > in harmonic_series_cps_n 17 55 == r -harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a] -harmonic_series_cps_n n = take n . harmonic_series_cps +-- | A real valued division of a semi-tone into one hundred parts, and +-- hence of the octave into @1200@ parts. +type Cents = Double --- | Sub-harmonic series on /n/. -subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t] -subharmonic_series_cps n = map (* n) (map recip [1..]) +-- | Integral cents value. +type Cents_I = Int --- | /n/ elements of 'harmonic_series_cps'. --- --- > let r = [1760,880,587,440,352,293,251,220,196,176,160,147,135,126,117,110,104] --- > in map round (subharmonic_series_cps_n 17 1760) == r -subharmonic_series_cps_n :: (Fractional t,Enum t) => Int -> t -> [t] -subharmonic_series_cps_n n = take n . subharmonic_series_cps +-- | Type specialised 'fratio_to_cents'. +approximate_ratio_to_cents :: Approximate_Ratio -> Cents +approximate_ratio_to_cents = fratio_to_cents --- | /n/th partial of /f1/, ie. one indexed. +-- | 'approximate_ratio_to_cents' '.' 'approximate_ratio'. -- --- > map (partial 55) [1,5,3] == [55,275,165] -partial :: (Num a, Enum a) => a -> Int -> a -partial f1 k = harmonic_series_cps f1 `at` (k - 1) +-- > import Data.Ratio {- base -} +-- > map (\n -> (n,round (ratio_to_cents (fold_ratio_to_octave_err (n % 1))))) [1..21] +ratio_to_cents :: Integral i => Ratio i -> Cents +ratio_to_cents = approximate_ratio_to_cents . realToFrac --- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@. +-- | Construct an exact 'Rational' that approximates 'Cents' to within /epsilon/. -- --- > map fold_ratio_to_octave [2/3,3/4] == [4/3,3/2] -fold_ratio_to_octave :: Integral i => Ratio i -> Ratio i -fold_ratio_to_octave n = - if n >= 2 - then fold_ratio_to_octave (n / 2) - else if n < 1 - then fold_ratio_to_octave (n * 2) - else n - --- | The interval between two pitches /p/ and /q/ given as ratio --- multipliers of a fundamental is /q/ '/' /p/. The classes over such --- intervals consider the 'fold_ratio_to_octave' of both /p/ to /q/ --- and /q/ to /p/. +-- > map (reconstructed_ratio 1e-5) [0,700,1200,1800] == [1,442/295,2,577/204] -- --- > map ratio_interval_class [2/3,3/2,3/4,4/3] == [3/2,3/2,3/2,3/2] -ratio_interval_class :: Integral i => Ratio i -> Ratio i -ratio_interval_class i = - let f = fold_ratio_to_octave - in max (f i) (f (recip i)) +-- > ratio_to_cents (442/295) == 699.9976981706735 +reconstructed_ratio :: Double -> Cents -> Rational +reconstructed_ratio epsilon c = approxRational (cents_to_fratio c) epsilon --- | Derivative harmonic series, based on /k/th partial of /f1/. --- --- > import Music.Theory.Pitch --- --- > let {r = [52,103,155,206,258,309,361,412,464,515,567,618,670,721,773] --- > ;d = harmonic_series_cps_derived 5 (octpc_to_cps (1,4))} --- > in map round (take 15 d) == r -harmonic_series_cps_derived :: (Ord a, Fractional a, Enum a) => Int -> a -> [a] -harmonic_series_cps_derived k f1 = - let f0 = fold_cps_to_octave_of f1 (partial f1 k) - in harmonic_series_cps f0 +-- * Commas --- | Harmonic series to /n/th harmonic (folded). +-- | The Syntonic comma. -- --- > harmonic_series_folded 17 == [1,17/16,9/8,5/4,11/8,3/2,13/8,7/4,15/8] +-- > syntonic_comma == 81/80 +syntonic_comma :: Rational +syntonic_comma = 81 % 80 + +-- | The Pythagorean comma. -- --- > let r = [0,105,204,386,551,702,841,969,1088] --- > in map (round . ratio_to_cents) (harmonic_series_folded 17) == r -harmonic_series_folded :: Integer -> [Rational] -harmonic_series_folded n = - nub (sort (map fold_ratio_to_octave [1 .. n%1])) +-- > pythagorean_comma == 3^12 / 2^19 +pythagorean_comma :: Rational +pythagorean_comma = 531441 / 524288 --- | 'ratio_to_cents' variant of 'harmonic_series_folded'. +-- | Mercators comma. -- --- > map round (harmonic_series_folded_c 21) == [0,105,204,298,386,471,551,702,841,969,1088] -harmonic_series_folded_c :: Integer -> [Cents] -harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded +-- > mercators_comma == 3^53 / 2^84 +mercators_comma :: Rational +mercators_comma = 19383245667680019896796723 / 19342813113834066795298816 --- | @12@-tone tuning of first @21@ elements of the harmonic series. +-- | 12-tone equal temperament comma (ie. 12th root of 2). -- --- > cents_i harmonic_series_folded_21 == [0,105,204,298,386,471,551,702,841,969,1088] --- > divisions harmonic_series_folded_21 == 11 -harmonic_series_folded_21 :: Tuning -harmonic_series_folded_21 = Tuning (Left (harmonic_series_folded 21)) 2 +-- > twelve_tone_equal_temperament_comma == 1.0594630943592953 +twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a +twelve_tone_equal_temperament_comma = 12 `T.nth_root` 2 -- * Cents -- | Give cents difference from nearest 12ET tone. -- -- > let r = [50,-49,-2,0,2,49,50] --- > in map cents_et12_diff [650,651,698,700,702,749,750] == r +-- > map cents_et12_diff [650,651,698,700,702,749,750] == r cents_et12_diff :: Integral n => n -> n cents_et12_diff n = let m = n `mod` 100 @@ -307,7 +209,7 @@ -- | Fractional form of 'cents_et12_diff'. fcents_et12_diff :: Real n => n -> n fcents_et12_diff n = - let m = n `mod'` 100 + let m = n `Fixed.mod'` 100 in if m > 50 then m - 100 else m -- | The class of cents intervals has range @(0,600)@. @@ -315,7 +217,7 @@ -- > map cents_interval_class [50,1150,1250] == [50,50,50] -- -- > let r = concat [[0,50 .. 550],[600],[550,500 .. 0]] --- > in map cents_interval_class [1200,1250 .. 2400] == r +-- > map cents_interval_class [1200,1250 .. 2400] == r cents_interval_class :: Integral a => a -> a cents_interval_class n = let n' = n `mod` 1200 @@ -324,7 +226,7 @@ -- | Fractional form of 'cents_interval_class'. fcents_interval_class :: Real a => a -> a fcents_interval_class n = - let n' = n `mod'` 1200 + let n' = n `Fixed.mod'` 1200 in if n' > 600 then 1200 - n' else n' -- | Always include the sign, elide @0@. @@ -355,41 +257,34 @@ cents_diff_html :: (Num a, Ord a, Show a) => a -> String cents_diff_html = cents_diff_br ("","") --- * Midi - --- | (/n/ -> /dt/). Function from midi note number /n/ to --- 'Midi_Detune' /dt/. The incoming note number is the key pressed, --- which may be distant from the note sounded. -type Midi_Tuning_F = Int -> T.Midi_Detune +-- * Savart --- | (t,c,k) where t=tuning (must have 12 divisions of octave), --- c=cents deviation (ie. constant detune offset), k=midi offset --- (ie. value to be added to incoming midi note number). -type D12_Midi_Tuning = (Tuning,Cents,Int) +-- | Felix Savart (1791-1841), the ratio of 10:1 is assigned a value of 1000 savarts. +type Savarts = Double --- | 'Midi_Tuning_F' for 'D12_Midi_Tuning'. +-- | Ratio to savarts. -- --- > import Music.Theory.Tuning.Gann --- > let f = d12_midi_tuning_f (la_monte_young,-74.7,-3) --- > octpc_to_midi (-1,11) == 11 --- > map (round . midi_detune_to_cps . f) [62,63,69] == [293,298,440] -d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_F -d12_midi_tuning_f (t,c_diff,k) n = - let (_,pc) = T.midi_to_octpc (n + k) - dt = zipWith (-) (cents t) [0,100 .. 1200] - in (n,(dt `at` pc) + c_diff) +-- > fratio_to_savarts 10 == 1000 +-- > fratio_to_savarts 2 == 301.02999566398114 +fratio_to_savarts :: Floating a => a -> a +fratio_to_savarts r = 1000 * logBase 10 r --- | (t,f0,k) where t=tuning, f0=fundamental frequency, k=midi note --- number for f0, n=gamut -type CPS_Midi_Tuning = (Tuning,Double,Int,Int) +-- | Savarts to ratio. +-- +-- > savarts_to_fratio 1000 == 10 +-- > savarts_to_fratio 301.02999566398118 == 2 +savarts_to_fratio :: Floating a => a -> a +savarts_to_fratio s = 10 ** (s / 1000) --- | 'Midi_Tuning_F' for 'CPS_Midi_Tuning'. -cps_midi_tuning_f :: CPS_Midi_Tuning -> Midi_Tuning_F -cps_midi_tuning_f (t,f0,k,g) n = - let r = approximate_ratios_cyclic t - m = take g (map (T.cps_to_midi_detune . (* f0)) r) - in m `at` (n - k) +-- | Savarts to cents. +-- +-- > savarts_to_cents 1 == 3.9863137138648352 +savarts_to_cents :: Floating a => a -> a +savarts_to_cents s = s * (6 / (5 * logBase 10 2)) --- Local Variables: --- truncate-lines:t --- End: +-- | Cents to savarts. +-- +-- > cents_to_savarts 3.9863137138648352 == 1 +-- > cents_to_savarts 1200 == ratio_to_savarts 2 +cents_to_savarts :: Floating a => a -> a +cents_to_savarts c = c / (6 / (5 * logBase 10 2)) diff --git a/Music/Theory/Tuning/Alves.hs b/Music/Theory/Tuning/Alves.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Alves.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Bill Alves. -module Music.Theory.Tuning.Alves where - -import Music.Theory.Tuning {- hmt -} - --- | Ratios for 'harrison_ditone'. --- --- > let c = [0,114,204,294,408,498,612,702,816,906,996,1110] --- > in map (round . ratio_to_cents) harrison_ditone_r == c -harrison_ditone_r :: [Rational] -harrison_ditone_r = - [1,2187/2048 {- 256/243 -} - ,9/8,32/27 - ,81/64 - ,4/3,729/512 - ,3/2,6561/4096 {- 128/81 -} - ,27/16,16/9 - ,243/128] - --- | Ditone/pythagorean tuning, --- see --- --- > cents_i harrison_ditone == [0,114,204,294,408,498,612,702,816,906,996,1110] -harrison_ditone :: Tuning -harrison_ditone = Tuning (Left harrison_ditone_r) 2 diff --git a/Music/Theory/Tuning/Alves_1997.hs b/Music/Theory/Tuning/Alves_1997.hs --- a/Music/Theory/Tuning/Alves_1997.hs +++ b/Music/Theory/Tuning/Alves_1997.hs @@ -3,48 +3,58 @@ -- 1997. module Music.Theory.Tuning.Alves_1997 where -import Music.Theory.Tuning +import Music.Theory.Tuning.Type {- hmt -} +-- > import Music.Theory.Tuning {- hmt -} -- > let c = [0,231,498,765,996] --- > in map (round.to_cents_r) alves_slendro_r == c +-- > map (round . ratio_to_cents) alves_slendro_r == c alves_slendro_r :: [Rational] alves_slendro_r = [1,8/7,4/3,14/9,16/9] --- | HMC /slendro/ tuning. --- --- > cents_i alves_slendro == [0,231,498,765,996] +{- | HMC /slendro/ tuning. + +> cents_i alves_slendro == [0,231,498,765,996] + +> import Music.Theory.Tuning.Scala {- hmt -} +> scl <- scl_load "alves_slendro" +> tn_cents_i (scale_to_tuning 0.01 scl) == tn_cents_i alves_slendro +-} alves_slendro :: Tuning -alves_slendro = Tuning (Left alves_slendro_r) 2 +alves_slendro = Tuning (Left alves_slendro_r) Nothing -- > let c = [0,231,316,702,814] --- > in map (round.to_cents_r) alves_pelog_bem_r == c +-- > map (round . ratio_to_cents) alves_pelog_bem_r == c alves_pelog_bem_r :: [Rational] alves_pelog_bem_r = [1,8/7,6/5,3/2,8/5] --- | HMC /pelog bem/ tuning. --- --- > cents_i alves_pelog_bem == [0,231,316,702,814] +{- | HMC /pelog bem/ tuning. + +> tn_cents_i alves_pelog_bem == [0,231,316,702,814] + +> scl <- scl_load "alves_pelog" +> tn_cents_i (scale_to_tuning 0.01 scl) == [0,231,316,471,702,814,969] +-} alves_pelog_bem :: Tuning -alves_pelog_bem = Tuning (Left alves_pelog_bem_r) 2 +alves_pelog_bem = Tuning (Left alves_pelog_bem_r) Nothing -- > let c = [0,386,471,857,969] --- > in map (round.to_cents_r) alves_pelog_barang_r == c +-- > map (round . ratio_to_cents) alves_pelog_barang_r == c alves_pelog_barang_r :: [Rational] alves_pelog_barang_r = [1,5/4,21/16,105/64,7/4] --- | HMC /pelog 2,3,4,6,7/ tuning. +-- | HMC /pelog barang/ tuning. -- --- > cents_i alves_pelog_barang == [0,386,471,857,969] +-- > tn_cents_i alves_pelog_barang == [0,386,471,857,969] alves_pelog_barang :: Tuning -alves_pelog_barang = Tuning (Left alves_pelog_barang_r) 2 +alves_pelog_barang = Tuning (Left alves_pelog_barang_r) Nothing -- > let c = [0,386,471,702,969] --- > in map (round.to_cents_r) alves_pelog_23467 == c +-- > map (round . ratio_to_cents) alves_pelog_23467_r == c alves_pelog_23467_r :: [Rational] alves_pelog_23467_r = [1,5/4,21/16,3/2,7/4] --- | HMC /pelog barang/ tuning. +-- | HMC /pelog 2,3,4,6,7/ tuning. -- --- > cents_i alves_pelog_23467 == [0,386,471,702,969] +-- > tn_cents_i alves_pelog_23467 == [0,386,471,702,969] alves_pelog_23467 :: Tuning -alves_pelog_23467 = Tuning (Left alves_pelog_23467_r) 2 +alves_pelog_23467 = Tuning (Left alves_pelog_23467_r) Nothing diff --git a/Music/Theory/Tuning/Anamark.hs b/Music/Theory/Tuning/Anamark.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Anamark.hs @@ -0,0 +1,106 @@ +-- | Anamark tuning (TUN) files +-- +-- +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 diff --git a/Music/Theory/Tuning/Db.hs b/Music/Theory/Tuning/Db.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Db.hs @@ -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) + +-} + diff --git a/Music/Theory/Tuning/Db/Alves.hs b/Music/Theory/Tuning/Db/Alves.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Db/Alves.hs @@ -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, +-- +-- > 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 diff --git a/Music/Theory/Tuning/Db/Gann.hs b/Music/Theory/Tuning/Db/Gann.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Db/Gann.hs @@ -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 +-- +-- +-- > 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, . +-- +-- > 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 . +-- +-- > 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 +-- +-- +-- > 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 . +-- +-- > 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 . +-- +-- > 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 diff --git a/Music/Theory/Tuning/Db/Microtonal_Synthesis.hs b/Music/Theory/Tuning/Db/Microtonal_Synthesis.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Db/Microtonal_Synthesis.hs @@ -0,0 +1,231 @@ +-- | +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, . +-- +-- > 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 +-- +-- +-- > 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] + +-- | . +-- +-- > 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 +-- . +-- +-- > 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, +-- . +-- +-- > 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 +-- +-- +-- > 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 +-- +-- +-- > 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 +-- +-- +-- > 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 diff --git a/Music/Theory/Tuning/Db/Riley.hs b/Music/Theory/Tuning/Db/Riley.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Db/Riley.hs @@ -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 . +-- +-- > 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 diff --git a/Music/Theory/Tuning/Db/Werckmeister.hs b/Music/Theory/Tuning/Db/Werckmeister.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Db/Werckmeister.hs @@ -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 diff --git a/Music/Theory/Tuning/ET.hs b/Music/Theory/Tuning/ET.hs deleted file mode 100644 --- a/Music/Theory/Tuning/ET.hs +++ /dev/null @@ -1,248 +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 Music.Theory.List {- hmt -} -import Music.Theory.Pitch {- hmt -} -import Music.Theory.Pitch.Note {- hmt -} -import Music.Theory.Pitch.Spelling {- hmt -} -import Music.Theory.Tuning {- hmt -} - --- | 'octpc_to_pitch' and 'octpc_to_cps'. -octpc_to_pitch_cps :: (Floating n) => OctPC -> (Pitch,n) -octpc_to_pitch_cps x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps x) - --- | 12-tone equal temperament table equating 'Pitch' and frequency --- over range of human hearing, where @A4@ = @440@hz. --- --- > length tbl_12et == 132 --- > let min_max l = (minimum l,maximum l) --- > min_max (map (round . snd) tbl_12et) == (16,31609) -tbl_12et :: [(Pitch,Double)] -tbl_12et = - let z = [(o,pc) | o <- [0..10], pc <- [0..11]] - in map octpc_to_pitch_cps z - --- | 24-tone equal temperament variant of 'tbl_12et'. --- --- > length tbl_24et == 264 --- > min_max (map (round . snd) tbl_24et) == (16,32535) -tbl_24et :: [(Pitch,Double)] -tbl_24et = - let f x = let p = fmidi_to_pitch pc_spell_ks x - p' = pitch_rewrite_threequarter_alteration p - in (p',fmidi_to_cps x) - in map f [12,12.5 .. 143.5] - --- | Given an @ET@ table (or like) find bounds of frequency. --- --- > let r = Just (at_pair octpc_to_pitch_cps ((3,11),(4,0))) --- > in bounds_et_table tbl_12et 256 == r -bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s)) -bounds_et_table tbl = - let f (_,p) = compare p - in find_bounds True f tbl - --- | 'bounds_et_table' of 'tbl_12et'. --- --- > map bounds_12et_tone (hsn 17 55) -bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double)) -bounds_12et_tone = bounds_et_table tbl_12et - --- | Tuple indicating nearest 'Pitch' to /frequency/ with @ET@ --- frequency, and deviation in hertz and 'Cents'. -type HS_R p = (Double,p,Double,Double,Cents) - --- | /n/-decimal places. --- --- > ndp 3 (1/3) == "0.333" -ndp :: Int -> Double -> String -ndp = printf "%.*f" - --- | Pretty print 'HS_R'. -hs_r_pp :: (p -> String) -> Int -> HS_R p -> [String] -hs_r_pp pp n (f,p,pf,fd,c) = - let dp = ndp n - in [dp f - ,pp p - ,dp pf - ,dp fd - ,dp c] - -hs_r_pitch_pp :: Int -> HS_R Pitch -> [String] -hs_r_pitch_pp = hs_r_pp pitch_pp - --- | Form 'HS_R' for /frequency/ by consulting table. --- --- > let {f = 256 --- > ;f' = octpc_to_cps (4,0) --- > ;r = (f,Pitch C Natural 4,f',f-f',fratio_to_cents (f/f'))} --- > in nearest_et_table_tone tbl_12et 256 == r -nearest_et_table_tone :: [(p,Double)] -> Double -> HS_R p -nearest_et_table_tone tbl f = - case bounds_et_table tbl f of - Nothing -> error "nearest_et_table_tone: no bounds?" - Just ((lp,lf),(rp,rf)) -> - let ld = f - lf - rd = f - rf - in if abs ld < abs rd - then (f,lp,lf,ld,fratio_to_cents (f/lf)) - else (f,rp,rf,rd,fratio_to_cents (f/rf)) - --- | 'nearest_et_table_tone' for 'tbl_12et'. -nearest_12et_tone :: Double -> HS_R Pitch -nearest_12et_tone = nearest_et_table_tone tbl_12et - --- | 'nearest_et_table_tone' for 'tbl_24et'. --- --- > let r = "55.0 A1 55.0 0.0 0.0" --- > in unwords (hs_r_pitch_pp 1 (nearest_24et_tone 55)) == r -nearest_24et_tone :: Double -> HS_R Pitch -nearest_24et_tone = nearest_et_table_tone tbl_24et - --- * 72ET - --- | Monzo 72-edo HEWM notation. The domain is (-9,9). --- --- --- > let r = ["+",">","^","#<","#-","#","#+","#>","#^"] --- > in map alteration_72et_monzo [1 .. 9] == r --- --- > let r = ["-","<","v","b>","b+","b","b-","b<","bv"] --- > in map alteration_72et_monzo [-1,-2 .. -9] == r -alteration_72et_monzo :: Integral n => n -> String -alteration_72et_monzo n = - let spl = splitOn "," - asc = spl ",+,>,^,#<,#-,#,#+,#>,#^" - dsc = spl ",-,<,v,b>,b+,b,b-,b<,bv" - in case compare n 0 of - LT -> genericIndex dsc (- n) - EQ -> "" - GT -> genericIndex asc n - --- | Given a midi note number and @1/6@ deviation determine 'Pitch'' --- and frequency. --- --- > let {f = pitch'_pp . fst . pitch_72et --- > ;r = "C4 C+4 C>4 C^4 C#<4 C#-4 C#4 C#+4 C#>4 C#^4"} --- > in unwords (map f (zip (repeat 60) [0..9])) == r --- --- > let {f = pitch'_pp . fst . pitch_72et --- > ;r = "A4 A+4 A>4 A^4 Bb<4 Bb-4 Bb4 Bb+4 Bb>4 Bv4"} --- > in unwords (map f (zip (repeat 69) [0..9])) --- --- > let {f = pitch'_pp . fst . pitch_72et --- > ;r = "Bb4 Bb+4 Bb>4 Bv4 B<4 B-4 B4 B+4 B>4 B^4"} --- > in unwords (map f (zip (repeat 70) [0..9])) == r -pitch_72et :: (Int,Int) -> (Pitch',Double) -pitch_72et (x,n) = - let p = midi_to_pitch pc_spell_ks x - t = note p - a = alteration p - (t',n') = case a of - Flat -> if n < (-3) then (pred t,n + 6) else (t,n - 6) - Natural -> (t,n) - Sharp -> if n > 3 then (succ t,n - 6) else (t,n + 6) - _ -> error "pitch_72et: alteration?" - a' = alteration_72et_monzo n' - x' = fromIntegral x + (fromIntegral n / 6) - r = (Pitch' t' (fromIntegral n' % 12,a') (octave p),fmidi_to_cps x') - r' = if n > 3 - then pitch_72et (x + 1,n - 6) - else if n < (-3) - then pitch_72et (x - 1,n + 6) - else r - in case a of - Natural -> r' - _ -> r - --- | 72-tone equal temperament table equating 'Pitch'' and frequency --- over range of human hearing, where @A4@ = @440@hz. --- --- > length tbl_72et == 792 --- > min_max (map (round . snd) tbl_72et) == (16,33167) -tbl_72et :: [(Pitch',Double)] -tbl_72et = - let f n = map pitch_72et (zip (replicate 6 n) [0..5]) - in concatMap f [12 .. 143] - --- | 'nearest_et_table_tone' for 'tbl_72et'. --- --- > let r = "324.0 E<4 323.3 0.7 3.5" --- > in unwords (hs_r_pp pitch'_pp 1 (nearest_72et_tone 324)) --- --- > let {f = take 2 . hs_r_pp pitch'_pp 1 . nearest_72et_tone . snd} --- > in mapM_ (print . unwords . f) tbl_72et -nearest_72et_tone :: Double -> HS_R Pitch' -nearest_72et_tone = nearest_et_table_tone tbl_72et - --- * Detune - --- | 'Pitch' with 12-ET/24-ET tuning deviation given in 'Cents'. -type Pitch_Detune = (Pitch,Cents) - --- | Exract 'Pitch_Detune' from 'HS_R'. -hsr_to_pitch_detune :: HS_R Pitch -> Pitch_Detune -hsr_to_pitch_detune (_,p,_,_,c) = (p,c) - --- | Nearest 12-ET 'Pitch_Detune' to indicated frequency (hz). --- --- > nearest_pitch_detune_12et 452.8929841231365 -nearest_pitch_detune_12et :: Double -> Pitch_Detune -nearest_pitch_detune_12et = hsr_to_pitch_detune . nearest_12et_tone - --- | Nearest 24-ET 'Pitch_Detune' to indicated frequency (hz). --- --- > nearest_pitch_detune_24et 452.8929841231365 -nearest_pitch_detune_24et :: Double -> Pitch_Detune -nearest_pitch_detune_24et = hsr_to_pitch_detune . nearest_24et_tone - --- | Given /near/ function, /f0/ and ratio derive 'Pitch_Detune'. -ratio_to_pitch_detune :: (Double -> HS_R Pitch) -> OctPC -> Rational -> Pitch_Detune -ratio_to_pitch_detune near_f f0 r = - let f = octpc_to_cps f0 * realToFrac r - (_,p,_,_,c) = near_f f - in (p,c) - --- | Frequency (hz) of 'Pitch_Detune'. --- --- > pitch_detune_to_cps (octpc_to_pitch pc_spell_ks (4,9),50) -pitch_detune_to_cps :: Floating n => Pitch_Detune -> n -pitch_detune_to_cps (p,d) = cps_shift_cents (pitch_to_cps p) (realToFrac d) - --- | 'ratio_to_pitch_detune' of 'nearest_12et_tone' -ratio_to_pitch_detune_12et :: OctPC -> Rational -> Pitch_Detune -ratio_to_pitch_detune_12et = ratio_to_pitch_detune nearest_12et_tone - --- | 'ratio_to_pitch_detune' of 'nearest_24et_tone' -ratio_to_pitch_detune_24et :: OctPC -> Rational -> Pitch_Detune -ratio_to_pitch_detune_24et = ratio_to_pitch_detune nearest_24et_tone - -pitch_detune_in_octave_nearest :: Pitch -> Pitch_Detune -> Pitch_Detune -pitch_detune_in_octave_nearest p1 (p2,d2) = - let p2' = pitch_in_octave_nearest p1 p2 - in (p2',d2) - --- | Markdown pretty-printer for 'Pitch_Detune'. -pitch_detune_md :: Pitch_Detune -> String -pitch_detune_md (p,c) = - pitch_pp p ++ cents_diff_md (round c :: Integer) - --- | HTML pretty-printer for 'Pitch_Detune'. -pitch_detune_html :: Pitch_Detune -> String -pitch_detune_html (p,c) = - pitch_pp p ++ cents_diff_html (round c :: Integer) - --- | No-octave variant of 'pitch_detune_md'. -pitch_class_detune_md :: Pitch_Detune -> String -pitch_class_detune_md (p,c) = - pitch_class_pp p ++ cents_diff_md (round c :: Integer) - --- | No-octave variant of 'pitch_detune_html'. -pitch_class_detune_html :: Pitch_Detune -> String -pitch_class_detune_html (p,c) = - pitch_class_pp p ++ cents_diff_html (round c :: Integer) diff --git a/Music/Theory/Tuning/Efg.hs b/Music/Theory/Tuning/Efg.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Efg.hs @@ -0,0 +1,111 @@ +-- | Euler-Fokker genus +module Music.Theory.Tuning.Efg where + +import Data.List {- base -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Set.List as T {- hmt -} + +import Music.Theory.Tuning {- hmt -} + +-- | Normal form, value with occurences count (ie. exponent in notation above). +type Efg i = [(i,Int)] + +-- | Degree of Efg, ie. sum of exponents. +-- +-- > efg_degree [(3,3),(7,2)] == 3 + 2 +efg_degree :: Efg i -> Int +efg_degree = sum . map snd + +-- | Number of tones of Efg, ie. product of increment of exponents. +-- +-- > efg_tones [(3,3),(7,2)] == (3 + 1) * (2 + 1) +efg_tones :: Efg i -> Int +efg_tones = product . map ((+ 1) . snd) + +-- | Collate a genus given as a multiset into standard form, ie. histogram. +-- +-- > efg_collate [3,3,3,7,7] == [(3,3),(7,2)] +efg_collate :: Ord i => [i] -> Efg i +efg_collate = T.histogram . sort + +{- | Factors of Efg given with co-ordinate of grid location. + +> efg_factors [(3,3)] + +> let r = [([0,0],[]),([0,1],[7]),([0,2],[7,7]) +> ,([1,0],[3]),([1,1],[3,7]),([1,2],[3,7,7]) +> ,([2,0],[3,3]),([2,1],[3,3,7]),([2,2],[3,3,7,7]) +> ,([3,0],[3,3,3]),([3,1],[3,3,3,7]),([3,2],[3,3,3,7,7])] + +> efg_factors [(3,3),(7,2)] == r + +-} +efg_factors :: Efg i -> [([Int],[i])] +efg_factors efg = + let k = map (\(_,n) -> [0 .. n]) efg + k' = if length efg == 1 + then concatMap (map return) k + else T.nfold_cartesian_product k + z = map fst efg + f ix = (ix,concat (zipWith (\n m -> replicate n (z !! m)) ix [0..])) + in map f k' + +{- | Ratios of Efg, taking /n/ as the 1:1 ratio, with indices, folded into one octave. + +> import Data.List +> let r = sort $ map snd $ efg_ratios 7 [(3,3),(7,2)] +> r == [1/1,9/8,8/7,9/7,21/16,189/128,3/2,27/16,12/7,7/4,27/14,63/32] +> map (round . ratio_to_cents) r == [0,204,231,435,471,675,702,906,933,969,1137,1173] + + 0: 1/1 C 0.000 cents + 1: 9/8 D 203.910 cents + 2: 8/7 D+ 231.174 cents + 3: 9/7 E+ 435.084 cents + 4: 21/16 F- 470.781 cents + 5: 189/128 G- 674.691 cents + 6: 3/2 G 701.955 cents + 7: 27/16 A 905.865 cents + 8: 12/7 A+ 933.129 cents + 9: 7/4 Bb- 968.826 cents + 10: 27/14 B+ 1137.039 cents + 11: 63/32 C- 1172.736 cents + 12: 2/1 C 1200.000 cents + +> let r' = sort $ map snd $ efg_ratios 5 [(5,2),(7,3)] +> r' == [1/1,343/320,35/32,49/40,5/4,343/256,7/5,49/32,8/5,1715/1024,7/4,245/128] +> map (round . ratio_to_cents) r' == [0,120,155,351,386,506,583,738,814,893,969,1124] + +> let r'' = sort $ map snd $ efg_ratios 3 [(3,1),(5,1),(7,1)] +> r'' == [1/1,35/32,7/6,5/4,4/3,35/24,5/3,7/4] +> map (round . ratio_to_cents) r'' == [0,155,267,386,498,653,884,969] + +> let c0 = [0,204,231,435,471,675,702,906,933,969,1137,1173,1200] +> let c1 = [0,120,155,351,386,506,583,738,814,893,969,1124,1200] +> let c2 = [0,155,267,386,498,653,884,969,1200] +> let f (c',y) = map (\x -> (x,y,x,y + 10)) c' +> map f (zip [c0,c1,c2] [0,20,40]) + +-} +efg_ratios :: Real r => Rational -> Efg r -> [([Int],Rational)] +efg_ratios n = + let to_r = fold_ratio_to_octave_err . (/ n) . toRational . product + f (ix,i) = (ix,to_r i) + in map f . efg_factors + +{- | Generate a line drawing, as a set of (x0,y0,x1,y1) 4-tuples. + h=row height, m=distance of vertical mark from row edge, k=distance between rows + +> let e = [[3,3,3],[3,3,5],[3,5,5],[3,5,7],[3,7,7],[5,5,5],[5,5,7],[3,3,7],[5,7,7],[7,7,7]] +> let e = [[3,3,3],[5,5,5],[7,7,7],[3,3,5],[3,5,5],[5,5,7],[5,7,7],[3,7,7],[3,3,7],[3,5,7]] +> let e' = map efg_collate e +> efg_diagram_set (round,25,4,75) e' + +-} +efg_diagram_set :: (Enum n,Real n) => (Cents -> n,n,n,n) -> [Efg n] -> [(n,n,n,n)] +efg_diagram_set (to_f,h,m,k) e = + let f = (++ [1200]) . sort . map (to_f . ratio_to_cents . snd) . efg_ratios 1 + g (c,y) = let y' = y + h + b = [(0,y,1200,y),(0,y',1200,y')] + in b ++ map (\x -> (x,y + m,x,y' - m)) c + in concatMap g (zip (map f e) [0,k ..]) diff --git a/Music/Theory/Tuning/Et.hs b/Music/Theory/Tuning/Et.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Et.hs @@ -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). +-- +-- +-- > 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) diff --git a/Music/Theory/Tuning/Gann.hs b/Music/Theory/Tuning/Gann.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Gann.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | Kyle Gann. -module Music.Theory.Tuning.Gann where - -import Music.Theory.Tuning {- hmt -} - --- * Historical - --- | Cents for 'pietro_aaron_1523'. --- --- > let c = [0,76,193,310,386,503,580,697,773,890,1007,1083] --- > in map round pietro_aaron_1523_c == c -pietro_aaron_1523_c :: [Cents] -pietro_aaron_1523_c = - [0,76.0 - ,193.2,310.3 - ,386.3 - ,503.4,579.5 - ,696.8,772.6 - ,889.7,1006.8 - ,1082.9] - --- | Pietro Aaron (1523) meantone temperament, see --- --- --- > cents_i pietro_aaron_1523 == [0,76,193,310,386,503,580,697,773,890,1007,1083] -pietro_aaron_1523 :: Tuning -pietro_aaron_1523 = Tuning (Right pietro_aaron_1523_c) 2 - --- | Andreas Werckmeister (1645-1706), . -werckmeister_iii_c :: [Cents] -werckmeister_iii_c = - [0,90.225 - ,192.18,294.135 - ,390.225 - ,498.045,588.27 - ,696.09,792.18 - ,888.27,996.09 - ,1092.18] - --- | Cents for 'thomas_young_1799'. --- --- > let c = [0,94,196,298,392,500,592,698,796,894,1000,1092] --- > in map round thomas_young_1799_c == c -thomas_young_1799_c :: [Cents] -thomas_young_1799_c = - [0,93.9 - ,195.8,297.8 - ,391.7 - ,499.9,591.9 - ,697.9,795.8 - ,893.8,999.8 - ,1091.8] - --- | Thomas Young (1799), Well Temperament, . --- --- > cents_i thomas_young_1799 == [0,94,196,298,392,500,592,698,796,894,1000,1092] -thomas_young_1799 :: Tuning -thomas_young_1799 = Tuning (Right thomas_young_1799_c) 2 - --- | Ratios for 'zarlino'. -zarlino_r :: [Rational] -zarlino_r = [1/1,25/24,10/9,9/8,32/27,6/5,5/4,4/3,25/18,45/32,3/2,25/16,5/3,16/9,9/5,15/8] - --- | Gioseffo Zarlino, 1588, see . --- --- > divisions zarlino == 16 --- > cents_i zarlino == [0,71,182,204,294,316,386,498,569,590,702,773,884,996,1018,1088] -zarlino :: Tuning -zarlino = Tuning (Left zarlino_r) 2 - --- * 20th Century - --- | Ratios for 'la_monte_young'. --- --- > let c = [0,177,204,240,471,444,675,702,738,969,942,1173] --- > in map (round . ratio_to_cents) la_monte_young_r == c -la_monte_young_r :: [Rational] -la_monte_young_r = - [1,567/512 - ,9/8,147/128 - ,21/16 - ,1323/1024,189/128 - ,3/2,49/32 - ,7/4,441/256 - ,63/32] - --- | La Monte Young's \"The Well-Tuned Piano\", see --- . --- --- > cents_i la_monte_young == [0,177,204,240,471,444,675,702,738,969,942,1173] -la_monte_young :: Tuning -la_monte_young = Tuning (Left la_monte_young_r) 2 - --- | Ratios for 'ben_johnston'. --- --- > let c = [0,105,204,298,386,471,551,702,841,906,969,1088] --- > in map (round . ratio_to_cents) ben_johnston_r == c -ben_johnston_r :: [Rational] -ben_johnston_r = - [1,17/16 - ,9/8,19/16 - ,5/4 - ,21/16,11/8 - ,3/2,13/8 - ,27/16,7/4 - ,15/8] - --- | Ben Johnston's \"Suite for Microtonal Piano\" (1977), see --- --- --- > cents_i ben_johnston == [0,105,204,298,386,471,551,702,841,906,969,1088] -ben_johnston :: Tuning -ben_johnston = Tuning (Left ben_johnston_r) 2 - --- * Gann - --- | Ratios for 'gann_arcana_xvi'. -gann_arcana_xvi_r :: [Rational] -gann_arcana_xvi_r = - [1/1,21/20,16/15,9/8,7/6,6/5,11/9,5/4,21/16,4/3,27/20,7/5 - ,22/15,3/2,55/36,8/5,44/27,5/3,42/25,7/4,9/5,11/6,15/8,88/45] - --- | Kyle Gann, _Arcana XVI_, see . --- --- > let r = [0,84,112,204,267,316,347,386,471,498,520,583,663,702,734,814,845,884,898,969,1018,1049,1088,1161] --- > in cents_i gann_arcana_xvi == r -gann_arcana_xvi :: Tuning -gann_arcana_xvi = Tuning (Left gann_arcana_xvi_r) 2 - --- | Ratios for 'gann_superparticular'. -gann_superparticular_r :: [Rational] -gann_superparticular_r = [1/1,11/10,10/9,9/8,8/7,7/6,6/5,5/4,9/7,4/3,11/8,7/5,10/7,3/2,11/7,14/9,8/5,5/3,12/7,7/4,16/9,9/5] - --- | Kyle Gann, _Superparticular_, see . --- --- > divisions gann_superparticular == 22 --- --- > let r = [0,165,182,204,231,267,316,386,435,498,551,583,617,702,782,765,814,884,933,969,996,1018] --- > in cents_i gann_superparticular == r -gann_superparticular :: Tuning -gann_superparticular = Tuning (Left gann_superparticular_r) 2 diff --git a/Music/Theory/Tuning/Gann_1993.hs b/Music/Theory/Tuning/Gann_1993.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Gann_1993.hs @@ -0,0 +1,141 @@ +-- | Kyle Gann. "La Monte Young's The Well-Tuned Piano". +-- /Perspectives of New Music/, 31(1):134--162, Winter 1993. +module Music.Theory.Tuning.Gann_1993 where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Math as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuning.Graph.Euler as T {- hmt -} +import qualified Music.Theory.Tuning.Type as T {- hmt -} + +{- | Ratios for 'lmy_wtp'. lmy = La Monte Young. wtp = Well-Tuned Piano. + +> let c = [0,177,204,240,471,444,675,702,738,969,942,1173] +> in map (round . T.ratio_to_cents) lmy_wtp_r == c + +-} +lmy_wtp_r :: [Rational] +lmy_wtp_r = + [1,567/512 + ,9/8,147/128 + ,21/16 + ,1323/1024,189/128 + ,3/2,49/32 + ,7/4,441/256 + ,63/32] + +-- | The pitch-class of the key associated with each ratio of the tuning. +-- +-- > mapMaybe lmy_wtp_ratio_to_pc [1,1323/1024,7/4] == [3,8,0] +lmy_wtp_ratio_to_pc :: Rational -> Maybe T.PitchClass +lmy_wtp_ratio_to_pc r = fmap (T.mod12 . (+ 3)) (elemIndex r lmy_wtp_r) + +lmy_wtp_ratio_to_pc_err :: Rational -> T.PitchClass +lmy_wtp_ratio_to_pc_err = fromMaybe (error "lmy_wtp_ratio_to_pc") . lmy_wtp_ratio_to_pc + +-- | The list of all non-unison ascending intervals possible in 'lmy_wtp_r'. +-- +-- > length lmy_wtp_univ == 66 +lmy_wtp_univ :: [(Rational,(T.PitchClass,T.PitchClass))] +lmy_wtp_univ = + let f (p,q) = if p < q + then Just (T.ratio_interval_class (p/q) + ,(lmy_wtp_ratio_to_pc_err p + ,lmy_wtp_ratio_to_pc_err q)) + else Nothing + in mapMaybe f (T.all_pairs lmy_wtp_r lmy_wtp_r) + +{- | Collated and sorted 'lmy_wtp_univ'. + +> let r_cents_pp = show . round . T.ratio_to_cents + +> import qualified Music.Theory.Math as T {- hmt -} + +> let f (r,i) = concat [T.ratio_pp r," = " +> ,r_cents_pp r," = #" +> ,show (length i)," = " +> ,unwords (map show i)] + +> putStrLn $ unlines $ map f lmy_wtp_uniq + +3:2 = 702 = #9 = (3,10) (4,9) (5,10) (6,11) (6,1) (7,0) (7,2) (8,1) (9,2) +7:4 = 969 = #7 = (3,0) (5,2) (6,7) (7,10) (8,9) (11,0) (1,2) +7:6 = 267 = #6 = (4,8) (5,7) (6,2) (7,11) (9,1) (10,0) +9:7 = 435 = #4 = (4,1) (5,0) (6,9) (11,2) +9:8 = 204 = #6 = (3,5) (4,2) (6,8) (7,9) (11,1) (0,2) +21:16 = 471 = #6 = (3,7) (5,9) (6,0) (7,1) (8,2) (10,2) +27:14 = 1137 = #2 = (4,6) (9,11) +27:16 = 906 = #3 = (4,7) (8,11) (9,0) +49:32 = 738 = #3 = (3,11) (5,1) (6,10) +49:36 = 534 = #1 = (5,11) +63:32 = 1173 = #5 = (3,2) (4,5) (8,7) (9,10) (1,0) +49:48 = 36 = #2 = (5,6) (10,11) +81:56 = 639 = #1 = (4,11) +81:64 = 408 = #1 = (4,0) +147:128 = 240 = #3 = (3,6) (5,8) (10,1) +189:128 = 675 = #3 = (3,9) (4,10) (8,0) +441:256 = 942 = #2 = (3,1) (8,10) +567:512 = 177 = #1 = (3,4) +1323:1024 = 444 = #1 = (3,8) + +-} +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) + +{- | Gann, 1993, p.137. + +> cents_i lmy_wtp == [0,177,204,240,471,444,675,702,738,969,942,1173] + +> import Data.List {- base -} +> import Music.Theory.Tuning.Scala {- hmt -} +> scl <- scl_load "young-lm_piano" +> cents_i (scale_to_tuning 0.01 scl) == cents_i lmy_wtp + +> let f = d12_midi_tuning_f (lmy_wtp,-74.7,-3) +> import qualified Music.Theory.Pitch as T +> T.octpc_to_midi (-1,11) == 11 +> map (round . T.midi_detune_to_cps . f) [62,63,69] == [293,298,440] +> map (fmap round . T.midi_detune_normalise . f) [0 .. 127] + +-} +lmy_wtp :: T.Tuning +lmy_wtp = T.Tuning (Left lmy_wtp_r) Nothing + +-- | Ratios for 'lmy_wtp_1964. +lmy_wtp_1964_r :: [Rational] +lmy_wtp_1964_r = + let n = [1,279,9,147,21,93,189,3,49,7,31,63] + d = [1,256,8,128,16,64,128,2,32,4,16,32] + in zipWith (/) n d + +{- | La Monte Young's initial 1964 tuning for \"The Well-Tuned Piano\" (Gann, 1993, p.141). + +> cents_i lmy_wtp_1964 == [0,149,204,240,471,647,675,702,738,969,1145,1173] + +> import Music.Theory.Tuning.Scala +> let nm = ("young-lm_piano_1964","LaMonte Young's Well-Tuned Piano (1964)") +> let scl = tuning_to_scale nm lmy_wtp_1964 +> putStr $ unlines $ scale_pp scl + +-} +lmy_wtp_1964 :: T.Tuning +lmy_wtp_1964 = T.Tuning (Left lmy_wtp_1964_r) Nothing + +{- | Euler diagram for 'lmy_wtp'. + +let dir = "/home/rohan/sw/hmt/data/dot/" +let f = unlines . T.euler_plane_to_dot_rat (3,True) +writeFile (dir ++ "euler-wtp.dot") (f lmy_wtp_euler) + +-} +lmy_wtp_euler :: T.Euler_Plane Rational +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 + ;(c1,c2) = T.euler_align_rat (7/4,7/4) (l1,l2,l3)} + in ([l1,l2,l3],c1 ++ c2) diff --git a/Music/Theory/Tuning/Graph/Euler.hs b/Music/Theory/Tuning/Graph/Euler.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Graph/Euler.hs @@ -0,0 +1,124 @@ +-- | Euler plane diagrams as /dot/ language graphs. +-- +-- +module Music.Theory.Tuning.Graph.Euler where + +import Data.List {- base -} +import Data.Ratio {- base -} + +import qualified Music.Theory.Function as T {- hmt -} +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Pitch.Note as T {- hmt -} +import qualified Music.Theory.Show as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} + +-- | 'T.fold_ratio_to_octave_err' of '*'. +rat_mul :: Rational -> Rational -> Rational +rat_mul r = T.fold_ratio_to_octave_err . (* r) + +-- | 'T.fold_ratio_to_octave_err' of '/'. +rat_div :: Rational -> Rational -> Rational +rat_div p q = T.fold_ratio_to_octave_err (p / q) + +-- | /n/ = length, /m/ = multiplier, /r/ = initial ratio. +-- +-- > tun_seq 5 (3/2) 1 == [1/1,3/2,9/8,27/16,81/64] +tun_seq :: Int -> Rational -> Rational -> [Rational] +tun_seq n m = take n . iterate (rat_mul m) + +-- | All possible pairs of elements (/x/,/y/) where /x/ is from /p/ and /y/ from /q/. +-- +-- > all_pairs "ab" "cde" == [('a','c'),('a','d'),('a','e'),('b','c'),('b','d'),('b','e')] +all_pairs :: [t] -> [u] -> [(t,u)] +all_pairs p q = [(x,y) | x <- p, y <- q] + +-- | Give all pairs from (l2,l1) and (l3,l2) that are at interval ratios r1 and r2 respectively. +euler_align_rat :: T.T2 Rational -> T.T3 [Rational] -> T.T2 [T.T2 Rational] +euler_align_rat (r1,r2) (l1,l2,l3) = + let f r (p,q) = rat_mul p r == q + in (filter (f r1) (all_pairs l2 l1) + ,filter (f r2) (all_pairs l3 l2)) + +-- | Pretty printer for pitch class (UNICODE). +-- +-- > unwords (map pc_pp [0..11]) == "C♮ C♯ D♮ E♭ E♮ F♮ F♯ G♮ A♭ A♮ B♭ B♮" +pc_pp :: (Integral i,Show i) => i -> String +pc_pp x = + case T.pc_to_note_alteration_ks x of + Just (n,a) -> [T.note_pp n,T.alteration_symbol a] + Nothing -> error (show ("pc_pp",x)) + +-- | Show ratio as intergral ('round') cents value. +cents_pp :: Rational -> String +cents_pp = show . (round :: Double -> Integer) . T.ratio_to_cents + +-- | (unit-pitch-class,print-cents) +type RAT_LABEL_OPT = (Int,Bool) + +-- | Dot label for ratio, /k/ is the pitch-class of the unit ratio. +-- +-- > rat_label (0,False) 1 == "C♮\\n1:1" +-- > rat_label (3,True) (7/4) == "C♯=969\\n7:4" +rat_label :: RAT_LABEL_OPT -> Rational -> String +rat_label (k,with_cents) r = + if r < 1 || r >= 2 + then error (show ("rat_label",r)) + else concat [pc_pp (T.ratio_to_pc k r) + ,if with_cents + then '=' : cents_pp r + else "" + ,"\\n",T.ratio_pp r] + +-- | Generate value /dot/ node identifier for ratio. +-- +-- > rat_id (5/4) == "R_5_4" +rat_id :: Rational-> String +rat_id r = "R_" ++ show (numerator r) ++ "_" ++ show (denominator r) + +-- | Printer for edge label between given ratio nodes. +rat_edge_label :: (Rational, Rational) -> String +rat_edge_label (p,q) = concat [" (",T.ratio_pp (rat_div p q),")"] + +-- | Zip start-middle-end. +-- +-- > zip_sme (0,1,2) "abcd" == [(0,'a'),(1,'b'),(1,'c'),(2,'d')] +zip_sme :: (t,t,t) -> [u] -> [(t,u)] +zip_sme (s,m,e) xs = + case xs of + x0:x1:xs' -> (s,x0) : (m,x1) : T.at_last (\x -> (m,x)) (\x -> (e,x)) xs' + _ -> error "zip_sme: not SME list" + +-- | Euler diagram given as (/h/,/v/) duple, +-- where /h/ are the horizontal sequences and /v/ are the vertical edges. +type Euler_Plane t = ([[t]],[(t,t)]) + +-- | Ratios at plane, sorted. +euler_plane_r :: Ord t => Euler_Plane t -> [t] +euler_plane_r = sort . concat . fst + +-- | Apply /f/ at all nodes of the plane. +euler_plane_map :: (t -> u) -> Euler_Plane t -> Euler_Plane u +euler_plane_map f (p,q) = (map (map f) p,map (T.bimap1 f) q) + +-- | Generate /dot/ graph given printer functions and an /Euler_Plane/. +euler_plane_to_dot :: (t -> String,t -> String,(t,t) -> String) -> Euler_Plane t -> [String] +euler_plane_to_dot (n_id,n_pp,e_pp) (h,v) = + let mk_lab_term x = concat [" [label=\"",x,"\"];"] + node_to_dot x = concat [n_id x,mk_lab_term (n_pp x)] + subgraph_edges x = intercalate " -- " (map n_id x) ++ ";" + edge_to_dot (lhs,rhs) = concat [n_id lhs," -- ",n_id rhs,mk_lab_term (e_pp (lhs,rhs))] + subgraphs_to_dot (ty,x) = concat ["{rank=",ty,"; ",unwords (map n_id x),"}"] + in ["graph g {" + ,"graph [layout=\"dot\",rankdir=\"TB\",nodesep=0.5];" + ,"edge [fontsize=\"8\",fontname=\"century schoolbook\"];" + ,"node [shape=\"plaintext\",fontsize=\"10\",fontname=\"century schoolbook\"];"] ++ + map node_to_dot (concat h) ++ + map subgraph_edges h ++ + map edge_to_dot v ++ + map subgraphs_to_dot (zip_sme ("min","same","max") h) ++ + ["}"] + +-- | Variant with default printers and fixed node type. +euler_plane_to_dot_rat :: RAT_LABEL_OPT -> Euler_Plane Rational -> [String] +euler_plane_to_dot_rat opt = euler_plane_to_dot (rat_id,rat_label opt,rat_edge_label) diff --git a/Music/Theory/Tuning/Graph/Iset.hs b/Music/Theory/Tuning/Graph/Iset.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Graph/Iset.hs @@ -0,0 +1,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 +-} diff --git a/Music/Theory/Tuning/Hs.hs b/Music/Theory/Tuning/Hs.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Hs.hs @@ -0,0 +1,81 @@ +-- | Harmonic series +module Music.Theory.Tuning.Hs where + +import Data.List {- base -} +import Data.Ratio {- base -} +import qualified Safe {- safe -} + +import qualified Music.Theory.Pitch as T {- hmt -} +import Music.Theory.Tuning {- hmt -} +import Music.Theory.Tuning.Type {- hmt -} + + +-- | Harmonic series to /n/th partial, with indicated octave. +-- +-- > harmonic_series 17 2 +harmonic_series :: Integer -> Maybe Rational -> Tuning +harmonic_series n o = Tuning (Left [1 .. n%1]) (fmap Left o) + +-- | Harmonic series on /n/. +harmonic_series_cps :: (Num t, Enum t) => t -> [t] +harmonic_series_cps n = [n,n * 2 ..] + +-- | /n/ elements of 'harmonic_series_cps'. +-- +-- > let r = [55,110,165,220,275,330,385,440,495,550,605,660,715,770,825,880,935] +-- > harmonic_series_cps_n 17 55 == r +harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a] +harmonic_series_cps_n n = take n . harmonic_series_cps + +-- | Sub-harmonic series on /n/. +subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t] +subharmonic_series_cps n = map ((* n) . 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 + diff --git a/Music/Theory/Tuning/Load.hs b/Music/Theory/Tuning/Load.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Load.hs @@ -0,0 +1,85 @@ +-- | Functions to load a tuning definition and transform it into a sparse tuning function. +module Music.Theory.Tuning.Load where + +import System.Random {- random -} + +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. +-- +-- > load_cps_tbl "/home/rohan/dr.csv" +load_cps_tbl :: FilePath -> IO [(T.Midi,Double)] +load_cps_tbl nm = do + tbl <- T.csv_table_read_def id nm + let f e = case e of + [p,q] -> (read p,read q) + _ -> error "load_cps_tbl" + return (map f tbl) + +-- | Load scala scl file as 'T.Tuning'. +load_tuning_scl :: String -> IO T.Tuning +load_tuning_scl = fmap T.scale_to_tuning . T.scl_load + +-- | cps = (tuning-name,frequency-zero,midi-note-number-of-f0) +-- d12 = (tuning-name,cents-deviation,midi-note-offset) +type Load_Tuning_Opt = (String,Double,T.Midi) + +-- | Load scala file and apply 'T.cps_midi_tuning_f'. +load_tuning_cps :: 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 (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 (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) + in fmap f (load_cps_tbl nm) + +type Choose_f st t = [t] -> st-> (t,st) + +-- | Randomly choose from elements in table, equal weighting. +default_choose_f :: RandomGen g => Choose_f g t +default_choose_f l g = + let (i,g') = randomR (0,length l - 1) g + 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 (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 + [] -> (g,Nothing) + l -> let ((_,e),g') = choose_f l g + 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 ty opt = + case ty of + "cps" -> load_tuning_cps opt + "d12" -> load_tuning_d12 opt + "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 ty opt = + case ty of + "cps" -> fmap T.lift_sparse_tuning_f (load_tuning_cps opt) + "d12" -> fmap T.lift_sparse_tuning_f (load_tuning_d12 opt) + "tbl" -> load_tuning_tbl_st default_choose_f opt + _ -> error "cps|d12|tbl" diff --git a/Music/Theory/Tuning/Meyer_1929.hs b/Music/Theory/Tuning/Meyer_1929.hs --- a/Music/Theory/Tuning/Meyer_1929.hs +++ b/Music/Theory/Tuning/Meyer_1929.hs @@ -3,8 +3,9 @@ -- University of Missouri, 1929. p.22 module Music.Theory.Tuning.Meyer_1929 where -import Data.List -import Data.Ratio +import Data.List {- base -} +import Data.Ratio {- base -} + import qualified Music.Theory.Tuning as T -- | Odd numbers to /n/. @@ -17,17 +18,17 @@ -- -- > row 7 == [1,5/4,3/2,7/4] row :: Integral i => i -> [Ratio i] -row = sort . map T.fold_ratio_to_octave . odd_to . (% 1) +row = sort . map T.fold_ratio_to_octave_err . odd_to . (% 1) -- | Generate initial column for /n/. -- -- > column 7 == [1,8/5,4/3,8/7] column :: Integral i => i -> [Ratio i] -column = map (T.fold_ratio_to_octave . recip) . row +column = map (T.fold_ratio_to_octave_err . recip) . row -- | 'T.fold_to_octave' '.' '*'. in_oct_mul :: Integral i => Ratio i -> Ratio i -> Ratio i -in_oct_mul i j = T.fold_ratio_to_octave (i * j) +in_oct_mul i j = T.fold_ratio_to_octave_err (i * j) -- | Given /row/ and /column/ generate matrix value at /(i,j)/. -- @@ -94,13 +95,17 @@ degree :: Integral i => i -> i degree = genericLength . elements --- | --- --- > let r = [[0,1/2,1] --- > ,[0,1/3,1/2,2/3,1] --- > ,[0,1/4,1/3,1/2,2/3,3/4,1] --- > ,[0,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,1] --- > ,[0,1/6,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,5/6,1]] --- > in map farey_sequence [2..6] == r +{- | + +> r = [[0 ] +> ,[0 ,1] +> ,[0 ,1/2 ,1] +> ,[0 ,1/3 ,1/2 ,2/3 ,1] +> ,[0 ,1/4,1/3 ,1/2 ,2/3,3/4 ,1] +> ,[0 ,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5 ,1] +> ,[0,1/6,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,5/6,1]] + +> map farey_sequence [0..6] +-} farey_sequence :: Integral a => a -> [Ratio a] farey_sequence k = 0 : nub (sort [n%d | d <- [1..k], n <- [1..d]]) diff --git a/Music/Theory/Tuning/Microtonal_Synthesis.hs b/Music/Theory/Tuning/Microtonal_Synthesis.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Microtonal_Synthesis.hs +++ /dev/null @@ -1,205 +0,0 @@ --- | -module Music.Theory.Tuning.Microtonal_Synthesis where - -import Music.Theory.Tuning {- hmt -} - --- | Ratios for 'pythagorean'. --- --- > let c = [0,90,204,294,408,498,612,702,792,906,996,1110] --- > in map (round . ratio_to_cents) pythagorean_r == c -pythagorean_r :: [Rational] -pythagorean_r = - [1,256/243 {- 2187/2048 -} - ,9/8,32/27 - ,81/64 - ,4/3,729/512 - ,3/2,128/81 {- 6561/4096 -} - ,27/16,16/9 - ,243/128] - --- | Pythagorean tuning, . --- --- > divisions pythagorean == 12 --- > cents_i pythagorean == [0,90,204,294,408,498,612,702,792,906,996,1110] -pythagorean :: Tuning -pythagorean = Tuning (Left pythagorean_r) 2 - --- | Ratios for 'five_limit_tuning'. --- --- > let c = [0,112,204,316,386,498,590,702,814,884,996,1088] --- > in map (round . ratio_to_cents) five_limit_tuning_r == c -five_limit_tuning_r :: [Rational] -five_limit_tuning_r = - [1,16/15 - ,9/8,6/5 - ,5/4 - ,4/3,45/32 {- 64/45 -} - ,3/2,8/5 - ,5/3,16/9 {- 9/5 -} - ,15/8] - --- | Five-limit tuning (five limit just intonation). --- --- > cents_i five_limit_tuning == [0,112,204,316,386,498,590,702,814,884,996,1088] -five_limit_tuning :: Tuning -five_limit_tuning = Tuning (Left five_limit_tuning_r) 2 - --- | Ratios for 'septimal_tritone_just_intonation'. --- --- > let c = [0,112,204,316,386,498,583,702,814,884,1018,1088] --- > in map (round . ratio_to_cents) septimal_tritone_just_intonation == c -septimal_tritone_just_intonation_r :: [Rational] -septimal_tritone_just_intonation_r = - [1,16/15 - ,9/8,6/5 - ,5/4 - ,4/3,7/5 - ,3/2,8/5 - ,5/3,9/5 - ,15/8] - --- | Septimal tritone Just Intonation, see --- --- --- > cents_i septimal_tritone_just_intonation == [0,112,204,316,386,498,583,702,814,884,1018,1088] -septimal_tritone_just_intonation :: Tuning -septimal_tritone_just_intonation = Tuning (Left septimal_tritone_just_intonation_r) 2 - --- | Ratios for 'seven_limit_just_intonation'. --- --- > let c = [0,112,204,316,386,498,583,702,814,884,969,1088] --- > in map (round . ratio_to_cents) seven_limit_just_intonation == c -seven_limit_just_intonation_r :: [Rational] -seven_limit_just_intonation_r = - [1,16/15 - ,9/8,6/5 - ,5/4 - ,4/3,7/5 - ,3/2,8/5 - ,5/3,7/4 - ,15/8] - --- | Seven limit Just Intonation. --- --- > cents_i seven_limit_just_intonation == [0,112,204,316,386,498,583,702,814,884,969,1088] -seven_limit_just_intonation :: Tuning -seven_limit_just_intonation = Tuning (Left seven_limit_just_intonation_r) 2 - --- | Approximate ratios for 'kirnberger_iii'. --- --- > let c = [0,90,193,294,386,498,590,697,792,890,996,1088] --- > in map (round.to_cents) kirnberger_iii_ar == c -kirnberger_iii_ar :: [Approximate_Ratio] -kirnberger_iii_ar = - [1,256/243 - ,sqrt 5 / 2,32/27 - ,5/4 - ,4/3,45/32 - ,5 ** 0.25,128/81 - ,(5 ** 0.75)/2,16/9 - ,15/8] - --- | . --- --- > cents_i kirnberger_iii == [0,90,193,294,386,498,590,697,792,890,996,1088] -kirnberger_iii :: Tuning -kirnberger_iii = Tuning (Right (map approximate_ratio_to_cents kirnberger_iii_ar)) 2 - --- > let c = [0,94,196,298,392,502,592,698,796,894,1000,1090] --- > in map round vallotti_c == c -vallotti_c :: [Cents] -vallotti_c = - [0.0,94.135 - ,196.09,298.045 - ,392.18 - ,501.955,592.18 - ,698.045,796.09 - ,894.135,1000.0 - ,1090.225] - --- | Vallotti & Young scale (Vallotti version), see --- . --- --- > cents_i vallotti == [0,94,196,298,392,502,592,698,796,894,1000,1090] -vallotti :: Tuning -vallotti = Tuning (Right vallotti_c) 2 - --- > let c = [0,128,139,359,454,563,637,746,841,911,1072,1183] --- > in map (round . ratio_to_cents) mayumi_reinhard == c -mayumi_reinhard_r :: [Rational] -mayumi_reinhard_r = - [1,14/13 - ,13/12,16/13 - ,13/10 - ,18/13,13/9 - ,20/13,13/8 - ,22/13,13/7 - ,208/105] - --- | Mayumi Reinhard 13-limit Just Intonation scale, --- . --- --- > cents_i mayumi_reinhard == [0,128,139,359,454,563,637,746,841,911,1072,1183] -mayumi_reinhard :: Tuning -mayumi_reinhard = Tuning (Left mayumi_reinhard_r) 2 - --- | Ratios for 'lou_harrison_16'. --- --- > length lou_harrison_16_r == 16 --- --- > let c = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088] --- > in map (round . ratio_to_cents) lou_harrison_16_r == c -lou_harrison_16_r :: [Rational] -lou_harrison_16_r = - [1,16/15 - ,10/9,8/7 - ,7/6,6/5,5/4 - ,4/3 - ,17/12 - ,3/2 - ,8/5,5/3,12/7 - ,7/4,9/5,15/8] - --- | Lou Harrison 16 tone Just Intonation scale, see --- --- --- > let r = [0,112,182,231,267,316,386,498,603,702,814,884,933,969,1018,1088] --- > in cents_i lou_harrison_16 == r -lou_harrison_16 :: Tuning -lou_harrison_16 = Tuning (Left lou_harrison_16_r) 2 - --- | Ratios for 'partch_43'. -partch_43_r :: [Rational] -partch_43_r = - [1,81/80,33/32,21/20,16/15,12/11,11/10,10/9,9/8,8/7 - ,7/6,32/27,6/5,11/9,5/4,14/11,9/7 - ,21/16,4/3,27/20 - ,11/8,7/5,10/7,16/11 - ,40/27,3/2,32/21,14/9,11/7,8/5,18/11,5/3,27/16,12/7 - ,7/4,16/9,9/5,20/11,11/6,15/8,40/21,64/33,160/81] - --- | Harry Partch 43 tone scale, see --- --- --- > cents_i partch_43 == [0,22,53,84,112,151,165 --- > ,182,204,231,267,294,316 --- > ,347,386,418,435 --- > ,471,498,520,551,583,617,649 --- > ,680,702,729,765,782,814,853,884,906,933 --- > ,969,996,1018,1035,1049,1088,1116,1147,1178] -partch_43 :: Tuning -partch_43 = Tuning (Left partch_43_r) 2 - --- | Ratios for 'ben_johnston_25'. -ben_johnston_25_r :: [Rational] -ben_johnston_25_r = - [1/1,25/24,135/128,16/15,10/9 - ,9/8,75/64,6/5,5/4,81/64 - ,32/25,4/3,27/20,45/32,36/25 - ,3/2,25/16,8/5,5/3,27/16 - ,225/128,16/9,9/5,15/8,48/25] - --- | Ben Johnston 25 note just enharmonic scale, see --- -ben_johnston_25 :: Tuning -ben_johnston_25 = Tuning (Left ben_johnston_25_r) 2 diff --git a/Music/Theory/Tuning/Midi.hs b/Music/Theory/Tuning/Midi.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Midi.hs @@ -0,0 +1,128 @@ +-- | Midi + Tuning +module Music.Theory.Tuning.Midi where + +import Data.List {- base -} +import qualified Data.Map as M {- containers -} +import Data.Maybe {- base -} +import qualified Safe {- safe -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Map as T {- hmt -} +import qualified Music.Theory.Pitch as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} + +import Music.Theory.Tuning {- hmt -} +import Music.Theory.Tuning.Type {- hmt -} + +-- | (/n/ -> /dt/). Function from midi note number /n/ to +-- 'Midi_Detune' /dt/. The incoming note number is the key pressed, +-- which may be distant from the note sounded. +type Midi_Tuning_f = T.Midi -> T.Midi_Detune + +-- | Variant for tunings that are incomplete. +type Sparse_Midi_Tuning_f = T.Midi -> Maybe T.Midi_Detune + +-- | Variant for sparse tunings that require state. +type Sparse_Midi_Tuning_St_f st = st -> T.Midi -> (st,Maybe T.Midi_Detune) + +-- | Lift 'Midi_Tuning_f' to 'Sparse_Midi_Tuning_f'. +lift_tuning_f :: Midi_Tuning_f -> Sparse_Midi_Tuning_f +lift_tuning_f tn_f = Just . tn_f + +-- | Lift 'Sparse_Midi_Tuning_f' to 'Sparse_Midi_Tuning_St_f'. +lift_sparse_tuning_f :: Sparse_Midi_Tuning_f -> Sparse_Midi_Tuning_St_f st +lift_sparse_tuning_f tn_f st k = (st,tn_f k) + +-- | (t,c,k) where +-- t=tuning (must have 12 divisions of octave), +-- c=cents deviation (ie. constant detune offset), +-- k=midi offset (ie. value to be added to incoming midi note number). +type D12_Midi_Tuning = (Tuning,Cents,T.Midi) + +-- | 'Midi_Tuning_f' for 'D12_Midi_Tuning'. +-- +-- > let f = d12_midi_tuning_f (equal_temperament 12,0,0) +-- > map f [0..127] == zip [0..127] (repeat 0) +d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_f +d12_midi_tuning_f (t,c_diff,k) n = + let (_,pc) = T.midi_to_octpc (n + k) + dt = zipWith (-) (tn_cents t) [0,100 .. 1200] + in if tn_divisions t /= 12 + then error "d12_midi_tuning_f: not d12" + else case dt `Safe.atMay` pc of + Nothing -> error "d12_midi_tuning_f: pc?" + Just c -> (n,c + c_diff) + +-- | (t,f0,k,g) where +-- t=tuning, f0=fundamental-frequency, k=midi-note-number (for f0), g=gamut +type Cps_Midi_Tuning = (Tuning,Double,T.Midi,Int) + +-- | 'Midi_Tuning_f' for 'Cps_Midi_Tuning'. The function is sparse, it is only +-- valid for /g/ values from /k/. +-- +-- > import qualified Music.Theory.Pitch as T +-- > let f = cps_midi_tuning_f (equal_temperament 72,T.midi_to_cps 59,59,72 * 4) +-- > map f [59 .. 59 + 72] +cps_midi_tuning_f :: Cps_Midi_Tuning -> Sparse_Midi_Tuning_f +cps_midi_tuning_f (t,f0,k,g) n = + let r = tn_approximate_ratios_cyclic t + m = take g (map (T.cps_to_midi_detune . (* f0)) r) + in m `Safe.atMay` T.midi_to_int (n - k) + +-- * Midi tuning tables. + +-- | midi-note-number -> fractional-midi-note-number table, possibly sparse. +type Mnn_Fmnn_Table = [(Int,Double)] + +-- | Load 'Mnn_Fmnn_Table' from two-column Csv file. +mnn_fmnn_table_load_csv :: FilePath -> IO Mnn_Fmnn_Table +mnn_fmnn_table_load_csv fn = do + s <- readFile fn + let f x = case break (== ',') x of + (lhs,_:rhs) -> (read lhs,read rhs) + _ -> error "mnn_fmidi_table_load_csv?" + return (map f (lines s)) + +-- | Midi-note-number -> Cps table, possibly sparse. +type Mnn_Cps_Table = [(T.Midi,Double)] + +-- | Generates 'Mnn_Cps_Table' given 'Midi_Tuning_f' with keys for all valid @Mnn@. +-- +-- > import Sound.SC3.Plot +-- > let f = cps_midi_tuning_f (equal_temperament 12,T.midi_to_cps 0,0,127) +-- > plot_p2_ln [map (fmap round) (gen_cps_tuning_tbl f)] +gen_cps_tuning_tbl :: Sparse_Midi_Tuning_f -> Mnn_Cps_Table +gen_cps_tuning_tbl tn_f = + let f n = case tn_f n of + Just r -> Just (n,T.midi_detune_to_cps r) + Nothing -> Nothing + in mapMaybe f [0 .. 127] + +-- * Derived (secondary) tuning table (DTT) lookup. + +-- | Given an 'Mnn_Cps_Table' /tbl/, a list of @Cps@ /c/, and a @Mnn@ /m/ +-- find the @Cps@ in /c/ that is nearest to the @Cps@ in /t/ for /m/. +-- In equal distance cases bias left. +dtt_lookup :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (Maybe v,Maybe v) +dtt_lookup tbl cps n = + let f = lookup n tbl + in (f,fmap (T.find_nearest_err True cps) f) + +-- | Require table be non-sparse. +dtt_lookup_err :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (k,v,v) +dtt_lookup_err tbl cps n = + case dtt_lookup tbl cps n of + (Just f,Just g) -> (n,f,g) + _ -> error "dtt_lookup" + +-- | Given two tuning tables generate the @dtt@ table. +gen_dtt_lookup_tbl :: Mnn_Cps_Table -> Mnn_Cps_Table -> Mnn_Cps_Table +gen_dtt_lookup_tbl t0 t1 = + let ix = [0..127] + cps = sort (map (T.p3_third . dtt_lookup_err t0 (map snd t1)) ix) + in zip ix cps + +gen_dtt_lookup_f :: Mnn_Cps_Table -> Mnn_Cps_Table -> Midi_Tuning_f +gen_dtt_lookup_f t0 t1 = + let m = M.fromList (gen_dtt_lookup_tbl t0 t1) + in T.cps_to_midi_detune . T.map_ix_err m diff --git a/Music/Theory/Tuning/Partch.hs b/Music/Theory/Tuning/Partch.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Partch.hs @@ -0,0 +1,68 @@ +-- | Tuning, Harry Partch +module Music.Theory.Tuning.Partch where + +import qualified Data.Map.Strict as M {- containers -} +import Data.Ratio {- base -} + +import qualified Music.Theory.Tuning as T + +orelate :: Integral i => Ratio i -> i -> Ratio i +orelate r m = T.fold_ratio_to_octave_err (r * (m % 1)) + +urelate :: Integral i => Ratio i -> i -> Ratio i +urelate r m = T.fold_ratio_to_octave_err (r * (1 % m)) + +-- | Incipient Tonality Diamond +-- +-- > itd_map [4 .. 6] +itd_map :: [Integer] -> M.Map (Int,Int) Rational +itd_map relation = + let limit = length relation + z = map (orelate 1) relation + c0 = zip (map (\n -> (n,0)) [0 .. limit - 1]) z + cN = [((i,k),urelate (z !! i) (relation !! k)) | + i <- [0 .. limit - 1], + k <- [1 .. limit - 1]] + in M.fromList (c0 ++ cN) + +map_to_table :: t -> (Int,Int) -> M.Map (Int,Int) t -> [[t]] +map_to_table k (nr,nc) m = + [[M.findWithDefault k (i,j) m | j <- [0 .. nc - 1]] | i <- [0 .. nr - 1]] + +-- | 'map_to_table' of 'itd_map'. +-- +-- > itd_tbl [4 .. 13] +itd_tbl :: [Integer] -> [[Rational]] +itd_tbl r = + let err = error "itd_tbl" + n = length r + in map_to_table err (n,n) (itd_map r) + +{- + +import Data.List {- base -} +import qualified Music.Theory.Array.Text as T {- hmt -} +import qualified Music.Theory.Show as T {- hmt -} + +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 +$ 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 +$ + +-} diff --git a/Music/Theory/Tuning/Polansky_1978.hs b/Music/Theory/Tuning/Polansky_1978.hs --- a/Music/Theory/Tuning/Polansky_1978.hs +++ b/Music/Theory/Tuning/Polansky_1978.hs @@ -1,30 +1,47 @@ --- | Larry Polansky. \"Psaltery (for Lou Harrison)\". Frog Peak Music, --- 1978. +-- | Larry Polansky. \"Psaltery (for Lou Harrison)\". +-- Frog Peak Music, 1978. module Music.Theory.Tuning.Polansky_1978 where -import Data.List -import qualified Music.Theory.Tuning as T +import Data.List {- base -} --- | Three interlocking harmonic series on 1:5:3, by Larry Polansky in --- \"Psaltery\". --- --- > import qualified Music.Theory.Tuning.Scala as T --- > let fn = "/home/rohan/opt/scala/scl/polansky_ps.scl" --- > s <- T.load fn --- > T.scale_pitch_representations s == (0,50) --- > 1 : Data.Either.rights (T.scale_pitches s) == psaltery -psaltery :: [Rational] -psaltery = [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,5/4,5/2,15/4,5,25/4,15/2,35/4,10,45/4,25/2,55/4,15,65/4,35/2,75/4,20,85/4,3/2,3,9/2,6,15/2,9,21/2,12,27/2,15,33/2,18,39/2,21,45/2,24,51/2] +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuning.Type as T {- hmt -} --- | 'T.fold_ratio_to_octave' of 'psaltery'. --- --- > length psaltery == 51 && length psaltery_o == 21 --- > psaltery_o == [1,65/64,33/32,17/16,35/32,9/8,75/64,39/32 --- > ,5/4,21/16,85/64,11/8,45/32 --- > ,3/2,25/16,51/32,13/8,27/16,55/32,7/4,15/8] -psaltery_o :: [Rational] -psaltery_o = nub (sort (map T.fold_ratio_to_octave psaltery)) +{- | Three interlocking harmonic series on 1:5:3, by Larry Polansky in \"Psaltery\". --- Local Variables: --- truncate-lines:t --- End: +> import qualified Music.Theory.Tuning.Scala as T +> scl <- T.scl_load "polansky_ps" +> T.pitch_representations (T.scale_pitches scl) == (0,50) +> 1 : Data.Either.rights (T.scale_pitches scl) == psaltery_r + +-} +psaltery_r :: [Rational] +psaltery_r = + let sq_at n = map (* n) [1..17] + in concat [sq_at 1,sq_at (5/4),sq_at (3/2)] + +{- | 'T.fold_ratio_to_octave'' of 'psaltery'. + +> length psaltery_r == 51 && length psaltery_o_r == 21 + +> psaltery_o_r == [1,65/64,33/32,17/16,35/32,9/8,75/64,39/32 +> ,5/4,21/16,85/64,11/8,45/32 +> ,3/2,25/16,51/32,13/8,27/16,55/32,7/4,15/8] + +-} +psaltery_o_r :: [Rational] +psaltery_o_r = nub (sort (map T.fold_ratio_to_octave_err psaltery_r)) + +{- | 'Tuning' derived from 'psaltery_o' with 'octave_ratio' of @2@. + +> cents_i psaltery_o == [0,27,53,105,155,204,275,342,386,471,491,551,590 + ,702,773,807,841,906,938,969,1088] + +> let r = [0,1200,1902,2400,2786,3102,3369,3600,3804,3986,4151,4302,4441,4569,4688,4800,4905 + ,386,1586,2288,2786,3173,3488,3755,3986,4190,4373,4538,4688,4827,4955,5075,5186,5291 + ,702,1902,2604,3102,3488,3804,4071,4302,4506,4688,4853,5004,5142,5271,5390,5502] +> in cents_i (T.scale_tuning 0.01 scl) == r + +-} +psaltery_o :: T.Tuning +psaltery_o = T.Tuning (Left psaltery_o_r) Nothing diff --git a/Music/Theory/Tuning/Polansky_1984.hs b/Music/Theory/Tuning/Polansky_1984.hs --- a/Music/Theory/Tuning/Polansky_1984.hs +++ b/Music/Theory/Tuning/Polansky_1984.hs @@ -2,9 +2,11 @@ -- Interval Sizes in Javanese Slendro\". /Balungan/, 1(2):9-11, 1984 module Music.Theory.Tuning.Polansky_1984 where -import Data.List -import Music.Theory.Tuning +import Data.List {- base -} +import qualified Music.Theory.List as T +import qualified Music.Theory.Tuning as T + k_manisrenga :: Fractional n => [n] k_manisrenga = [219.5,266.5,227,233.5,258.5] @@ -100,12 +102,6 @@ let f n (i,j) = i <= n && n < j in maybe "U" snd (find (f x . fst) i_categories) --- | Pad 'String' to right with spaces until at least /n/ characters. --- --- > map (pad 3) ["S","E-L"] == ["S ","E-L"] -pad :: Int -> String -> String -pad n s = s ++ replicate (n - length s) ' ' - -- | Pretty interval category table (pp. 10-11). -- -- > i_category_table k_set == @@ -128,7 +124,7 @@ -- > ,"S-E S L E L " -- > ,"S S E-L L L "] i_category_table :: (Ord a, Num a) => [[a]] -> [String] -i_category_table = map (intercalate " " . map (pad 3 . i_category)) +i_category_table = map (intercalate " " . map (T.pad_right ' ' 3 . i_category)) -- | Rational tuning derived from 'gm_averages', p.11. -- @@ -148,5 +144,5 @@ -- -- > import Music.Theory.List -- > map round (d_dx polansky_1984_c) == [231,240,223,240,231] -polansky_1984_c :: [Cents] -polansky_1984_c = map ratio_to_cents polansky_1984_r +polansky_1984_c :: [T.Cents] +polansky_1984_c = map T.ratio_to_cents polansky_1984_r diff --git a/Music/Theory/Tuning/Polansky_1985c.hs b/Music/Theory/Tuning/Polansky_1985c.hs --- a/Music/Theory/Tuning/Polansky_1985c.hs +++ b/Music/Theory/Tuning/Polansky_1985c.hs @@ -1,16 +1,16 @@ -- | 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 {- hmt -} +import Music.Theory.Tuning.Type {- hmt -} -- | The tuning has four octaves, these ratios are per-octave. ps5_jpr_r :: [[Rational]] ps5_jpr_r = - [[1/1, 21/20, 9/8, 6/5, 5/4, 4/3, 7/5, 3/2, 8/5, 5/3, 7/4, 15/8] - ,[1/1, 21/20, 9/8, 6/5, 5/4, 4/3, 7/5, 3/2, 8/5, 5/3, 7/4, 15/8] - ,[1/1, 33/32, 9/8, 6/5, 5/4, 21/16, 11/8, 3/2, 8/5, 13/8, 7/4, 15/8] - ,[1/1, 21/20, 9/8, 7/6, 5/4, 4/3, 11/8, 3/2, 8/5, 27/16, 7/4, 15/8]] + [[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)) - in Tuning (Left r) 16 + 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)) diff --git a/Music/Theory/Tuning/Riley.hs b/Music/Theory/Tuning/Riley.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Riley.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | Terry Riley. -module Music.Theory.Tuning.Riley where - -import Music.Theory.Tuning {- hmt -} - --- | Ratios for 'riley_albion'. --- --- > let r = [0,112,204,316,386,498,610,702,814,884,996,1088] --- > in map (round . ratio_to_cents) riley_albion_r == r -riley_albion_r :: [Rational] -riley_albion_r = [1/1,16/15,9/8,6/5,5/4,4/3,64/45,3/2,8/5,5/3,16/9,15/8] - --- | Riley's five-limit tuning as used in _The Harp of New Albion_, --- see . --- --- > cents_i riley_albion == [0,112,204,316,386,498,610,702,814,884,996,1088] -riley_albion :: Tuning -riley_albion = Tuning (Left riley_albion_r) 2 diff --git a/Music/Theory/Tuning/Rosenboom_1979.hs b/Music/Theory/Tuning/Rosenboom_1979.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Rosenboom_1979.hs @@ -0,0 +1,143 @@ +-- | David Rosenboom, "In the Beginning: Etude I (Trombones)", 1979 +-- +-- +-- kw: subharmonics, difference tones +module Music.Theory.Tuning.Rosenboom_1979 where + +import Data.List {- base -} +import Data.Ratio {- base -} + +import qualified Music.Theory.Function as T +import qualified Music.Theory.List as T +import qualified Music.Theory.Pitch as T +import qualified Music.Theory.Pitch.Name as T +import qualified Music.Theory.Tuning.Et as T +import qualified Music.Theory.Tuning.Scala as Scala +import qualified Music.Theory.Tuple as T + +t2_to_ratio :: (Integer,Integer) -> Rational +t2_to_ratio (n,d) = n % d + +-- | Tuning, ratios for each octave. +-- +-- > length (concat dr_tuning_oct) == 19 +-- > import qualified Music.Theory.Tuning as T +-- > map (map (T.ratio_to_cents . t2_to_ratio)) dr_tuning_oct +dr_tuning_oct :: Num n => [[(n,n)]] +dr_tuning_oct = + [[(1,1),(4,3),(16,11),(8,5),(16,9)] + ,[(1,1),(8,7),(4,3),(3,2),(8,5),(16,9)] + ,[(1,1),(9,8),(5,4),(4,3),(11,8),(3,2),(8,5),(7,4)]] + +-- | Tuning, actual ratios. +dr_tuning :: [Rational] +dr_tuning = concat (zipWith (\o -> map ((* o) . t2_to_ratio)) [1,2,4] dr_tuning_oct) + +-- | 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] +-- > map round dr_scale == r +dr_scale :: [Double] +dr_scale = + let f0 = T.octpc_to_cps (1::Int,8) + f = (* f0) . fromRational + in map f dr_tuning + +-- > 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_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 = 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)) + r_seq = snd (mapAccumL g 1 [33 .. 32 + 12 * 3 - 1]) ++ [(68,8)] + in ("dr_itb_etude_1","...",3 * 12,map (Right . snd) r_seq) + +-- > 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_k0 (69,440)) dr_scale + +dr_chords :: [[T.Pitch]] +dr_chords = + [[T.aes1,T.bes2,T.des3,T.ees4] -- S1 + ,[T.aes1,T.aes2,T.fes3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] -- S2 + ,[T.aes1,T.ges2,T.aes3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] + ,[T.aes1,T.bes2,T.des3,T.ees4] -- S3 + ,[T.aes1,T.ges2,T.aes3,T.ees4] + ,[T.aes1,T.ges2,T.aes3,T.ees4] -- S4 + ,[T.aes1,T.aes2,T.fes3,T.ees4] + ,[T.aes1,T.fes2,T.des4,T.ees4] -- S5 + ,[T.ges2,T.aes2,T.aes3,T.d4] + ,[T.aes1,T.d2,T.aes3,T.ees4] + ,[T.aes2,T.fes3,T.d4] -- S6 + ,[T.aes1,T.fes2,T.des4,T.ees4] + ,[T.aes1,T.fes2,T.des4,T.ees4] -- S7 + ,[T.aes1,T.ges2,T.aes3,T.ees4] + ,[T.aes1,T.ges2,T.aes3,T.ees4] -- S8 + ,[T.aes1,T.d2,T.aes3,T.ees4] + ] + +-- > sum (map snd (concat dr_ratio_seq)) == 20 * 11 +-- > map (sum . map snd) dr_ratio_seq == replicate 20 11 +dr_ratio_seq :: Num n => [[(n,n)]] +dr_ratio_seq = + [[(11,3),(2,2),(6,6)] + ,[(7,2),(7,7),(6,2)] + ,[(6,9),(2,2)] + ,[(2,9),(11,2)] + ,[(10,5),(10,3),(10,3)] + ,[(10,10),(5,1)] + ,[(5,7),(11,4)] + ,[(11,3),(8,8)] + ,[(8,8),(10,3)] -- p2 + ,[(10,7),(10,4)] + ,[(10,4),(3,3),(4,4)] + ,[(4,3),(9,7),(5,1)] + ,[(7,7),(7,4)] + ,[(9,9),(9,2)] + ,[(9,7),(7,4)] + ,[(7,3),(9,4),(7,4)] + ,[(5,3),(4,4),(6,1),(4,3)] + ,[(4,4),(7,7)] + ,[(7,2),(5,8),(8,1)] + ,[(8,1),(1,10)] + ] + +-- > 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) + +dr_nt :: Integral i => [([i],[i])] +dr_nt = + [([1,7,8,17],[12,13,15,17]) + ,([1,6,10,17],[6,10,9])] + +-- > map (T.bimap1 (map T.pitch_pp) . dr_nt_pitch) dr_nt +dr_nt_pitch :: ([Int], [Int]) -> ([T.Pitch], [T.Pitch]) +dr_nt_pitch = + let f k = T.p5_snd (dr_scale_tbl_24et !! (k - 1)) + in T.bimap1 (map f) + +{- + +-- from harmonic series +hs :: Num n => [(n,n)] +hs = [(1,1),(9,8),(5,4),(11,8),(3,2),(7,4)] + +-- from subharmonic series +shs :: Num n => [(n,n)] +shs = [(8,7),(16,11),(8,5),(16,9)] + +-} diff --git a/Music/Theory/Tuning/Scala.hs b/Music/Theory/Tuning/Scala.hs --- a/Music/Theory/Tuning/Scala.hs +++ b/Music/Theory/Tuning/Scala.hs @@ -1,196 +1,504 @@ --- | Parser for the Scala scale file format. See --- for details. --- This module succesfully parses all 4496 scales in v.81 of the scale --- library. +{- | Parser for the Scala scale file format. + +See for details. + +This module succesfully parses all scales in v.91 of the scale library. + +-} module Music.Theory.Tuning.Scala where -import qualified Codec.Binary.UTF8.String as U {- utf8-string -} -import qualified Data.ByteString as B {- bytestring -} -import Data.List -import Data.Ratio -import qualified Music.Theory.Tuning as T +import Control.Monad {- base -} +import Data.Either {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} import System.Directory {- directory -} +import System.Environment {- base -} import System.FilePath {- filepath -} --- | A @.scl@ pitch is either in 'Cents' or is a 'Ratio'. -type Pitch i = Either T.Cents (Ratio i) - --- | A scale has a description, a degree, and a list of 'Pitch'es. -type Scale i = (String,i,[Pitch i]) - --- | Text description of scale. -scale_description :: Scale i -> String -scale_description (d,_,_) = d +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 -} +import qualified Music.Theory.Tuning as T {- hmt -} +import qualified Music.Theory.Tuning.Type as T {- hmt -} --- | The degree of the scale (number of 'Pitch'es). -scale_degree :: Scale i -> i -scale_degree (_,n,_) = n +-- * Pitch --- | The 'Pitch'es at 'Scale'. -scale_pitches :: Scale i -> [Pitch i] -scale_pitches (_,_,p) = p +-- | A @.scl@ pitch is either in 'Cents' or is a 'Ratio'. +type Pitch = Either T.Cents Rational --- | The last 'Pitch' element of the scale (ie. the /ocatve/). -scale_octave :: Scale i -> Maybe (Pitch i) -scale_octave (_,_,s) = - case s of - [] -> Nothing - _ -> Just (last s) +-- | An enumeration type for @.scl@ pitch classification. +data Pitch_Type = Pitch_Cents | Pitch_Ratio deriving (Eq,Show) --- | Is 'scale_octave' perfect, ie. 'Ratio' of @2@ or 'Cents' of --- @1200@. -perfect_octave :: Integral i => Scale i -> Bool -perfect_octave s = scale_octave s `elem` [Just (Right 2),Just (Left 1200)] +-- | A nearness value for deriving approximate rationals. +type Epsilon = Double --- | A pair giving the number of 'Cents' and number of 'Ratio' pitches --- at 'Scale'. -scale_pitch_representations :: (Integral t) => Scale i -> (t,t) -scale_pitch_representations s = - let f (l,r) p = case p of - Left _ -> (l + 1,r) - Right _ -> (l,r + 1) - in foldl f (0,0) (scale_pitches s) +-- | Derive 'Pitch_Type' from 'Pitch'. +pitch_type :: Pitch -> Pitch_Type +pitch_type = either (const Pitch_Cents) (const Pitch_Ratio) --- | Pitch as 'T.Cents', conversion by 'T.to_cents_r' if necessary. -pitch_cents :: Pitch Integer -> T.Cents +-- | Pitch as 'T.Cents', conversion by 'T.ratio_to_cents' if necessary. +pitch_cents :: Pitch -> T.Cents pitch_cents p = case p of Left c -> c Right r -> T.ratio_to_cents r -type Epsilon = Double - -- | Pitch as 'Rational', conversion by 'T.reconstructed_ratio' if -- necessary, hence /epsilon/. -pitch_ratio :: Epsilon -> Pitch Integer -> Rational +pitch_ratio :: Epsilon -> Pitch -> Rational pitch_ratio epsilon p = case p of Left c -> T.reconstructed_ratio epsilon c Right r -> r --- | Make scale pitches uniform, conforming to the most promininent --- pitch type. -scale_uniform :: Epsilon -> Scale Integer -> Scale Integer -scale_uniform epsilon s = - let (d,n,p) = s - (c,r) = scale_pitch_representations s :: (Int,Int) - in if c >= r - then (d,n,map (Left . pitch_cents) p) - else (d,n,map (Right . pitch_ratio epsilon) p) +-- | A pair giving the number of 'Cents' and number of 'Ratio' pitches. +pitch_representations :: [Pitch] -> (Int,Int) +pitch_representations = + let f (l,r) p = case p of + Left _ -> (l + 1,r) + Right _ -> (l,r + 1) + in foldl f (0,0) +-- | If scale is uniform, give type. +uniform_pitch_type :: [Pitch] -> Maybe Pitch_Type +uniform_pitch_type p = + case pitch_representations p of + (0,_) -> Just Pitch_Ratio + (_,0) -> Just Pitch_Cents + _ -> Nothing + +-- | The predominant type of the pitches for 'Scale'. +pitch_type_predominant :: [Pitch] -> Pitch_Type +pitch_type_predominant p = + let (c,r) = pitch_representations p + in if c >= r then Pitch_Cents else Pitch_Ratio + +-- * Scale + +-- | A scale has a name, a description, a degree, and a sequence of pitches. +-- The /name/ is the the file-name without the /.scl/ suffix. +-- By convention the first comment line gives the file name (with suffix). +-- The pitches do NOT include 1:1 or 0c and do include the octave. +type Scale = (String,String,Int,[Pitch]) + +-- | The name of a scale. +scale_name :: Scale -> String +scale_name (nm,_,_,_) = nm + +-- | Text description of a scale. +scale_description :: Scale -> String +scale_description (_,d,_,_) = d + +-- | The degree of the scale (number of 'Pitch'es). +scale_degree :: Scale -> Int +scale_degree (_,_,n,_) = n + +-- | The 'Pitch'es at 'Scale'. +scale_pitches :: Scale -> [Pitch] +scale_pitches (_,_,_,p) = p + +-- | Is 'Pitch' outside of the standard octave (ie. cents 0-1200 and ratios 1-2) +pitch_non_oct :: Pitch -> Bool +pitch_non_oct p = + case p of + Left c -> c < 0 || c > 1200 + Right r -> r < 1 || r > 2 + +-- | Ensure degree and number of pitches align. +scale_verify :: Scale -> Bool +scale_verify (_,_,n,p) = n == length p + +-- | Raise error if scale doesn't verify, else 'id'. +scale_verify_err :: Scale -> Scale +scale_verify_err scl = if scale_verify scl then scl else error ("invalid scale: " ++ scale_name scl) + +-- | The last 'Pitch' element of the scale (ie. the /octave/). For empty scales give 'Nothing'. +scale_octave :: Scale -> Maybe Pitch +scale_octave (_,_,_,s) = + case s of + [] -> Nothing + _ -> Just (last s) + +-- | Error variant. +scale_octave_err :: Scale -> Pitch +scale_octave_err = fromMaybe (error "scale_octave?") . scale_octave + +-- | Is 'scale_octave' perfect, ie. 'Ratio' of @2@ or 'Cents' of @1200@. +perfect_octave :: Scale -> Bool +perfect_octave s = + case scale_octave s of + Just (Right 2) -> True + Just (Left 1200.0) -> True + _ -> False + +-- | Are all pitches of the same type. +is_scale_uniform :: Scale -> Bool +is_scale_uniform = isJust . uniform_pitch_type . scale_pitches + +-- | Are the pitches in ascending sequence. +is_scale_ascending :: Scale -> Bool +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 +scale_uniform epsilon (nm,d,n,p) = + case pitch_type_predominant p of + Pitch_Cents -> (nm,d,n,map (Left . pitch_cents) p) + Pitch_Ratio -> (nm,d,n,map (Right . pitch_ratio epsilon) p) + -- | Scale as list of 'T.Cents' (ie. 'pitch_cents') with @0@ prefix. -scale_cents :: Scale Integer -> [T.Cents] +scale_cents :: Scale -> [T.Cents] scale_cents s = 0 : map pitch_cents (scale_pitches s) +-- | 'map' 'round' of 'scale_cents'. +scale_cents_i :: Scale -> [T.Cents_I] +scale_cents_i = map round . scale_cents + -- | Scale as list of 'Rational' (ie. 'pitch_ratio') with @1@ prefix. -scale_ratios :: Epsilon -> Scale Integer -> [Rational] +scale_ratios :: Epsilon -> Scale -> [Rational] scale_ratios epsilon s = 1 : map (pitch_ratio epsilon) (scale_pitches s) --- | Comment lines being with @!@. -comment_p :: String -> Bool -comment_p x = +-- | Require that 'Scale' be uniformly of 'Ratio's. +scale_ratios_u :: Scale -> Maybe [Rational] +scale_ratios_u scl = + let err = error "scale_ratios_u?" + p = scale_pitches scl + in case uniform_pitch_type p of + Just Pitch_Ratio -> Just (1 : map (fromMaybe err . Either.from_right) p) + _ -> Nothing + +-- | Erroring variant of 'scale_ratios_u. +scale_ratios_req :: Scale -> [Rational] +scale_ratios_req = fromMaybe (error "scale_ratios_req") . scale_ratios_u + +{- | Are scales equal ('==') at degree and tuning data. + +> db <- scl_load_db +> let r = [2187/2048,9/8,32/27,81/64,4/3,729/512,3/2,6561/4096,27/16,16/9,243/128,2/1] +> let Just py = find (scale_eq ("","",length r,map Right r)) db +> scale_name py == "pyth_12" + +'scale_eqv' provides an approximate equality function. + +> let c = map T.ratio_to_cents r +> let Just py' = find (scale_eqv 0.00001 ("","",length c,map Left c)) db +> scale_name py' == "pyth_12" + +-} +scale_eq :: Scale -> Scale -> Bool +scale_eq (_,_,d0,p0) (_,_,d1,p1) = d0 == d1 && p0 == p1 + +-- | Are scales equal at degree and 'intersect' to at least /k/ places of tuning data. +scale_eq_n :: Int -> Scale -> Scale -> Bool +scale_eq_n k (_,_,d0,p0) (_,_,d1,p1) = d0 == d1 && length (p0 `intersect` p1) >= k + +-- | Is `s1` a proper subset of `s2`. +scale_sub :: Scale -> Scale -> Bool +scale_sub (_,_,d0,p0) (_,_,d1,p1) = d0 < d1 && intersect p0 p1 == p0 + +-- | Are scales equal at degree and equivalent to within /epsilon/ at 'pitch_cents'. +scale_eqv :: Epsilon -> Scale -> Scale -> Bool +scale_eqv epsilon (_,_,d0,p0) (_,_,d1,p1) = + let (~=) p q = abs (pitch_cents p - pitch_cents q) < epsilon + in d0 == d1 && and (zipWith (~=) p0 p1) + +-- * Parser + +-- | Comment lines begin with @!@. +is_comment :: String -> Bool +is_comment x = case x of '!':_ -> True _ -> False --- | Remove @\r@. -filter_cr :: String -> String -filter_cr = filter (not . (==) '\r') - --- | Logical /or/ of list of predicates. -p_or :: [a -> Bool] -> a -> Bool -p_or p x = - case p of - [] -> False - f:p' -> f x || p_or p' x - -- | Remove to end of line @!@ comments. +-- +-- > remove_eol_comments " 1 ! comment" == " 1 " remove_eol_comments :: String -> String remove_eol_comments = takeWhile (/= '!') --- | Remove comments and null lines. +-- | Remove comments and trailing comments (the description may be empty, keep nulls) -- --- > filter_comments ["!a","b","","c"] == ["b","c"] +-- > filter_comments ["!a","b","","c","d!e"] == ["b","","c","d"] filter_comments :: [String] -> [String] -filter_comments = map remove_eol_comments . - filter (not . p_or [comment_p,null]) - --- | Delete trailing @.@, 'read' fails for @700.@. -delete_trailing_point :: String -> String -delete_trailing_point s = - case reverse s of - '.':s' -> reverse s' - _ -> s +filter_comments = + map remove_eol_comments . + filter (not . Function.predicate_any [is_comment]) --- | Pitches are either cents (with decimal point) or ratios (with @/@). +-- | Pitches are either cents (with decimal point, possibly trailing) or ratios (with @/@). -- --- > map pitch ["700.0","3/2","2"] == [Left 700,Right (3/2),Right 2] -pitch :: (Read i,Integral i) => String -> Pitch i -pitch p = +-- > map parse_pitch ["70.0","350.","3/2","2","2/1"] == [Left 70,Left 350,Right (3/2),Right 2,Right 2] +parse_pitch :: String -> Pitch +parse_pitch p = if '.' `elem` p - then Left (read (delete_trailing_point p)) - else case break (== '/') p of - (n,'/':d) -> Right (read n % read d) - _ -> Right (read p % 1) + then Left (T.read_fractional_allow_trailing_point_err p) + else Right (T.read_ratio_with_div_err p) -- | Pitch lines may contain commentary. -pitch_ln :: (Read i, Integral i) => String -> Pitch i -pitch_ln x = +parse_pitch_ln :: String -> Pitch +parse_pitch_ln x = case words x of - p:_ -> pitch p - _ -> error (show ("pitch",words x)) + p:_ -> parse_pitch p + _ -> error (show ("parse_pitch_ln",words x)) -- | Parse @.scl@ file. -parse :: (Read i, Integral i) => String -> Scale i -parse s = - case filter_comments (lines (filter_cr s)) of - t:n:p -> (t,read n,map pitch_ln p) +parse_scl :: String -> String -> Scale +parse_scl nm s = + case filter_comments (lines (T.filter_cr s)) of + t:n:p -> let scl = (nm + ,T.delete_trailing_whitespace t + ,T.read_err_msg "degree" n + ,map parse_pitch_ln p) + in scale_verify_err scl _ -> error "parse" --- | Load @.scl@ file. +-- * Io + +-- | Read the environment variable @SCALA_SCL_DIR@, which is a +-- sequence of directories used to locate scala files on. -- --- > s <- load "/home/rohan/data/scala/81/scl/xenakis_chrom.scl" --- > scale_pitch_representations s == (6,1) +-- > 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. +-- It is an error if the name has a file extension. +-- +-- > mapM scl_derive_filename ["young-lm_piano","et12"] +scl_derive_filename :: FilePath -> IO FilePath +scl_derive_filename nm = do + 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") + 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/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" + in if isAbsolute nm && takeExtension nm == ".scl" + then doesFileExist nm >>= ex_f + else scl_derive_filename nm + +-- | Load @.scl@ file, runs 'resolve_scl'. +-- +-- > s <- scl_load "xenakis_chrom" +-- > pitch_representations (scale_pitches s) == (6,1) -- > scale_ratios 1e-3 s == [1,21/20,29/23,179/134,280/187,11/7,100/53,2] -load :: (Read i, Integral i) => FilePath -> IO (Scale i) -load fn = do - b <- B.readFile fn - let s = U.decode (B.unpack b) - return (parse s) +scl_load :: String -> IO Scale +scl_load nm = do + fn <- scl_resolve_name nm + s <- Io.read_file_iso_8859_1 fn + return (parse_scl (takeBaseName nm) s) --- | Subset of files in /dir/ with an extension in /ext/. -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))) +{- | Load all @.scl@ files at /dir/, associate with file-name. --- | Load all @.scl@ files at /dir/. +> 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 <- Directory.dir_subset [".scl"] d + scl <- mapM scl_load fn + return (zip fn scl) + +-- | 'snd' of 'scl_load_dir_fn' +scl_load_dir :: FilePath -> IO [Scale] +scl_load_dir = fmap (map snd) . scl_load_dir_fn + +-- | Load Scala data base at 'scl_get_dir'. -- --- > db <- load_dir "/home/rohan/data/scala/81/scl" --- > length db == 4496 --- > length (filter ((== 0) . scale_degree) db) == 0 --- > length (filter (== Just (Right 2)) (map scale_octave db)) == 3855 +-- > db <- scl_load_db +-- > mapM_ (putStrLn . unlines . scale_stat) (filter (not . perfect_octave) db) +scl_load_db :: IO [Scale] +scl_load_db = do + dir <- scl_get_dir + r <- mapM scl_load_dir dir + return (concat r) + +-- * Pp + +-- | +scales_dir_txt_tbl :: [Scale] -> [[String]] +scales_dir_txt_tbl = + let f s = [scale_name s,show (scale_degree s),scale_description s] + in map f + +-- | Format as CSV file. -- --- > let r = [2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24 --- > ,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44 --- > ,45,46,47,48,49,50,51,53,54,55,56,57,58,59,60,61,62,63,64 --- > ,65,66,67,68,69,70,71,72,74,75,77,78,79,80,81,84,87,88 --- > ,90,91,92,95,96,99,100,101,105,110,112,117,118,130,140,171 --- > ,180,271,311,342,366,441,612] --- > in nub (sort (map scale_degree db)) == r +-- > db <- scl_load_db +-- > writeFile "/tmp/scl.csv" (scales_dir_txt_csv db) +scales_dir_txt_csv :: [Scale] -> String +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. -- --- > let r = ["Xenakis's Byzantine Liturgical mode, 5 + 19 + 6 parts" --- > ,"Xenakis's Byzantine Liturgical mode, 12 + 11 + 7 parts" --- > ,"Xenakis's Byzantine Liturgical mode, 7 + 16 + 7 parts"] --- > in filter (isInfixOf "Xenakis") (map scale_description db) == r +-- > db <- scl_load_db +-- > writeFile "/tmp/scl.txt" (unlines (intercalate [""] (map scale_stat db))) +scale_stat :: Scale -> [String] +scale_stat s = + let p = scale_pitches s + u_ty = uniform_pitch_type p + n_ty = let p_ty = pitch_type_predominant p + (p_i,p_j) = pitch_representations p + in concat ["non-uniform (",show p_ty,",",show p_i,":",show p_j,")"] + in ["name : " ++ scale_name s + ,"description : " ++ scale_description s + ,"degree : " ++ show (scale_degree s) + ,"type : " ++ maybe n_ty show u_ty + ,"perfect-oct : " ++ show (perfect_octave s) + ,"cents-i : " ++ show (scale_cents_i s) + ,if u_ty == Just Pitch_Ratio + then "ratios : " ++ intercalate "," (map T.rational_pp (scale_ratios_req s)) + else ""] + +-- | Pretty print 'Pitch' in @Scala@ format. +pitch_pp :: Pitch -> String +pitch_pp p = + case p of + Left c -> show c + Right r -> show (numerator r) ++ "/" ++ show (denominator r) + +-- | Pretty print 'Scale' in @Scala@ format. -- --- > length (filter (not . perfect_octave) db) == 544 +-- > scl <- scl_load "et19" +-- > scl <- scl_load "young-lm_piano" +-- > putStr $ unlines $ scale_pp scl +scale_pp :: Scale -> [String] +scale_pp (nm,dsc,k,p) = + ["! " ++ nm ++ ".scl" + ,"!" + ,dsc + ,show k + ,"!"] ++ map pitch_pp p + +scale_wr :: FilePath -> Scale -> IO () +scale_wr fn = writeFile fn . unlines . scale_pp + +-- | Write /scl/ to /dir/ with the file-name 'scale_name'.scl +scale_wr_dir :: FilePath -> Scale -> IO () +scale_wr_dir dir scl = scale_wr (dir scale_name scl <.> "scl") scl + +-- * Dist + +-- | @scala@ distribution directory, given at @SCALA_DIST_DIR@. -- --- > mapM_ (putStrLn.scale_description) (filter (not . perfect_octave) db) -load_dir :: (Read i, Integral i) => FilePath -> IO [Scale i] -load_dir d = dir_subset [".scl"] d >>= mapM load +-- > setEnv "SCALA_DIST_DIR" "/home/rohan/opt/build/scala-22" +dist_get_dir :: IO String +dist_get_dir = getEnv "SCALA_DIST_DIR" --- Local Variables: --- truncate-lines:t --- End: +-- | Load file from 'dist_get_dir'. +load_dist_file :: FilePath -> IO String +load_dist_file nm = do + d <- dist_get_dir + readFile (d nm) + +{- | '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 + +-- | Is scale just-intonation (ie. are all pitches ratios) +scl_is_ji :: Scale -> Bool +scl_is_ji = (==) (Just Pitch_Ratio) . uniform_pitch_type . scale_pitches + +-- | Calculate limit for JI scale (ie. largest prime factor) +scl_ji_limit :: Scale -> Integer +scl_ji_limit = maximum . map fst . concatMap 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 (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..]) + +{- | Variant selecting only nearest and with post-processing function. + +> scl <- scl_load "holder" +> scale_cents_i scl +> c = [0,83,193,308,388,502,584,695,778,890,1004,1085,1200] +> (_,r,_) = scl_cdiff_abs_sum_1 round c scl +> r == [0,2,-1,1,0,-1,0,-1,0,0,0,0,0] +-} +scl_cdiff_abs_sum_1 :: (Double -> n) -> [T.Cents] -> Scale -> (Double,[n],Int) +scl_cdiff_abs_sum_1 pp c scl = + case scl_cdiff_abs_sum c scl of + [] -> error "scl_cdiff_abs_sum_1" + (n,d,r):_ -> (n,map pp d,r) + +{- | Sort DB into ascending order of sum of absolute of differences to scale given in cents. + Scales are sorted and all rotations are considered. + +> db <- scl_load_db +> c = [0,83,193,308,388,502,584,695,778,890,1004,1085,1200] +> r = scl_db_query_cdiff_asc round db c +> ((_,dx,_),_):_ = r +> dx == [0,2,-1,1,0,-1,0,-1,0,0,0,0,0] +> mapM_ (putStrLn . unlines . scale_stat . snd) (take 10 r) +-} +scl_db_query_cdiff_asc :: Ord n => (Double -> n) -> [Scale] -> [T.Cents] -> [((Double,[n],Int),Scale)] +scl_db_query_cdiff_asc pp db c = + let n = length c - 1 + db_n = filter ((== n) . scale_degree) db + in sort (map (\scl -> (scl_cdiff_abs_sum_1 pp c scl,scl)) db_n) + +-- | Is /x/ the same scale as /scl/ under /cmp/. +scale_cmp_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> Scale -> Bool +scale_cmp_ji cmp x scl = + case scale_ratios_u scl of + Nothing -> False + Just r -> cmp x r + +-- | Find scale(s) that are 'scale_cmp_ji' to /x/. +-- Usual /cmp/ are (==) and 'is_subset'. +scl_find_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> [Scale] -> [Scale] +scl_find_ji cmp x = filter (scale_cmp_ji cmp x) + +-- * Tuning + +-- | Translate 'Scale' to 'T.Tuning'. If 'Scale' is uniformly +-- rational, 'T.Tuning' is rational, else it is in 'T.Cents'. +scale_to_tuning :: Scale -> T.Tuning +scale_to_tuning (_,_,_,p) = + case partitionEithers p of + ([],r) -> let (r',o) = List.separate_last r + in T.Tuning (Left (1 : r')) (if o == 2 then Nothing else Just (Left o)) + _ -> 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 (Either.either_swap o) + in T.Tuning (Right c') o' + +-- | Convert 'T.Tuning' to 'Scale'. +-- +-- > tuning_to_scale ("et12","12 tone equal temperament") (T.tn_equal_temperament 12) +tuning_to_scale :: (String,String) -> T.Tuning -> Scale +tuning_to_scale (nm,dsc) tn@(T.Tuning p _) = + let n = either length length p + p' = either (map Right . tail) (map Left . tail) p ++ [Either.either_swap (T.tn_octave_def tn)] + in (nm,dsc,n,p') + +-- | 'scale_to_tuning' of 'scl_load'. +-- +-- > fmap T.tn_limit (scl_load_tuning "pyra") -- Just 59 +scl_load_tuning :: String -> IO T.Tuning +scl_load_tuning = fmap scale_to_tuning . scl_load diff --git a/Music/Theory/Tuning/Scala/Cli.hs b/Music/Theory/Tuning/Scala/Cli.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Cli.hs @@ -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 diff --git a/Music/Theory/Tuning/Scala/Functions.hs b/Music/Theory/Tuning/Scala/Functions.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Functions.hs @@ -0,0 +1,123 @@ +-- | Scala functions, +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 -} + +{- | + +> 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 ..] + +{- | + +> 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)) + +{- | + +> 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 diff --git a/Music/Theory/Tuning/Scala/Interval.hs b/Music/Theory/Tuning/Scala/Interval.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Interval.hs @@ -0,0 +1,86 @@ +-- | Parser for the SCALA @intnam.par@ file. +module Music.Theory.Tuning.Scala.Interval where + +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 -} + +-- | Interval and name, ie. (3/2,"perfect fifth") +type INTERVAL = (Rational,String) + +-- | Length prefixed list of 'INTERVAL'. +type INTNAM = (Int,[INTERVAL]) + +{- | Lookup ratio in 'INTNAM'. + +> db <- load_intnam +> intnam_search_ratio db (3/2) == Just (3/2,"perfect fifth") +> intnam_search_ratio db (2/3) == Nothing +> intnam_search_ratio db (4/3) == Just (4/3,"perfect fourth") +> intnam_search_ratio db (31/16) == Just (31/16,"=31st harmonic") +> 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. +-- +-- > db <- load_intnam +-- > intnam_search_description_ci db "didymus" == [(81/80,"syntonic comma, Didymus comma")] +intnam_search_description_ci :: INTNAM -> String -> [INTERVAL] +intnam_search_description_ci (_,i) x = + let downcase = map toLower + x' = downcase x + in filter (isInfixOf x' . downcase . snd) i + +-- * Parser + +-- | Parse line from intnam.par +parse_intnam_entry :: String -> INTERVAL +parse_intnam_entry str = + case words str of + r:w -> (Read.read_ratio_with_div_err r,unwords w) + _ -> error "parse_intnam_entry" + +-- | Parse non-comment lines from intnam.par +parse_intnam :: [String] -> INTNAM +parse_intnam l = + case l of + _:n:i -> let n' = read n :: Int + i' = map parse_intnam_entry i + in if n' == length i' then (n',i') else error "parse_intnam" + _ -> error "parse_intnam" + +-- * IO + +{- | 'parse_intnam' of 'Scala.load_dist_file_ln' of "intnam.par". + +> intnam <- load_intnam +> fst intnam == 516 -- Scala 2.42p +> fst intnam == length (snd intnam) +> lookup (129140163/128000000) (snd intnam) == Just "gravity comma" +-} +load_intnam :: IO INTNAM +load_intnam = do + l <- Scala.load_dist_file_ln "intnam.par" + return (parse_intnam (Scala.filter_comments l)) diff --git a/Music/Theory/Tuning/Scala/Kbm.hs b/Music/Theory/Tuning/Scala/Kbm.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Kbm.hs @@ -0,0 +1,217 @@ +{- | Scala "keyboard mapping" files (.kbm) and related data structure. + + +-} +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 + +-} diff --git a/Music/Theory/Tuning/Scala/Meta.hs b/Music/Theory/Tuning/Scala/Meta.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Meta.hs @@ -0,0 +1,196 @@ +-- | Scala DB meta-data. +module Music.Theory.Tuning.Scala.Meta where + +-- | Just-intonation (ie. all rational) scales, collected by author. +scl_ji_au :: [(String,[String])] +scl_ji_au = + [("Alves, Bill",words "alves_12 alves_22 alves_pelog alves alves_slendro") + ,("Archytas" + ,["arch_chrom","arch_chromc2" -- "archchro" NON-JI + ,"arch_dor" + ,"arch_enh","arch_enh2","arch_enh3","arch_enhp" + ,"arch_enht","arch_enht2","arch_enht3","arch_enht4","arch_enht5","arch_enht6","arch_enht7" + ,"arch_mult" + ,"arch_ptol","arch_ptol2" + ,"arch_sept" + -- "archytas7" "archytas12","archytas12sync" NON-JI + ]) + ,("Barlow, Clarence",words "barlow_13 barlow_17") + ,("Boethius",words "boeth_chrom boeth_enh") + ,("Burt, Warren", + concat [map (\n -> "burt" ++ show n) [1::Int .. 20] + ,words "burt_fibo burt_fibo23 burt_forks burt_primes"]) + ,("Chalmers, John" + ,["chalmers" + ,"chalmers_17" + ,"chalmers_19" + ,"chalmers_ji1" + ,"chalmers_ji2" + ,"chalmers_ji3" + ,"chalmers_ji4" + ,"corner7" + ,"corner11" + ,"corner13" + ,"corners7" + ,"corners11" + ,"corners13" + ,"finnamore_jc" + ,"hamilton_jc" + ,"major_clus" + ,"major_wing" + ,"minor_clus" + ,"minor_wing" + ,"pelog_jc" + ,"prod7d" + ,"prodq13" + ,"slen_pel_jc"]) + ,("Didymus", words "didy_chrom didy_chrom1 didy_chrom2 didy_chrom3 didy_diat didy_enh didy_enh2") + ,("Eratosthenes",words "eratos_chrom eratos_diat eratos_enh") + ,("Euler, Leonhard",words "euler euler_diat euler_enh euler_gm") + ,("Gann, Kyle",words "gann_arcana gann_charingcross gann_cinderella gann_custer gann_fractured gann_fugitive gann_ghost gann_love gann_new_aunts gann_revisited gann_sitting gann_solitaire gann_suntune gann_super gann_things gann_wolfe hulen_33") + ,("Grady, Kraig" + ,["dekany-cs" + ,"grady11" + ,"grady_14" + ,"grady_centaur" + ,"grady_centaur17" + ,"grady_centaur19"]) + ,("Hahn, Paul",words "duohex hahn_7 hahn9 hahnmaxr indian-hahn") -- hahn_g mean14a + ,("Harrison, Lou" + ,["dudon_slendro_matrix" -- NON-UNIQ + ,"harrison_5" + ,"harrison_5_1" + ,"harrison_5_3" -- NON-STEP + ,"harrison_5_4" -- NON-STEP + ,"harrison_8" -- NON-STEP + ,"harrison_15" + ,"harrison_16" + ,"harrison_bill" + ,"harrison_cinna" + ,"harrison_diat" + ,"harrison_handel" + ,"harrison_kyai" -- NON-STEP + ,"harrison_mid" + ,"harrison_mid2" + ,"harrison_mix2" + ,"harrison_mix3" -- NON-STEP + ,"harrison_mix4" + ,"harrison_slye" + ,"harrison_songs" + ,"hexany10" + ,"hirajoshi2" + ,"korea_5" + ,"olympos" + ,"pelog_jc" -- STRICT SONGS + ,"pelog_laras" -- NON-STEP + ,"prime_5" + ,"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" + ,"johnston_22" + ,"johnston_25" + ,"johnston_81" + ,"johnston_6-qt" + ,"johnston_6-qt_row"]) + ,("Kepler, Johannes",words "kepler1 kepler2 kepler3") + ,("Partch, Harry" + ,["kring1" + ,"diamond7" + ,"diamond9" + ,"diamond17b" + ,"novaro15" + ,"partch_29-av" + ,"partch_29" + ,"partch_37" + ,"partch_39" + ,"partch_41" + ,"partch_43" + ,"partch-barstow"]) + ,("Ptolemy" + ,["ptolemy_chrom" + ,"ptolemy_ddiat" + ,"ptolemy_diat","ptolemy_diat2","ptolemy_diat3","ptolemy_diat4","ptolemy_diat5" + ,"ptolemy_diff" + ,"ptolemy_enh" + ,"ptolemy_exp" + ,"ptolemy_ext" + ,"ptolemy_hominv","ptolemy_hominv2" + ,"ptolemy_hom" + ,"ptolemy_iastaiol","ptolemy_iast" + ,"ptolemy_ichrom" + ,"ptolemy_idiat" + ,"ptolemy_imix" + ,"ptolemy_malak","ptolemy_malak2" + ,"ptolemy_mdiat","ptolemy_mdiat2","ptolemy_mdiat3" + ,"ptolemy_meta" + ,"ptolemy_mix" + ,"ptolemy_perm" + ,"ptolemy_prod" + ,"ptolemy" + ,"ptolemy_tree"]) + ,("Pythagoras" + ,["pyth_7a","pyth_12","pyth_12s","pyth_17","pyth_17s","pyth_22","pyth_27","pyth_chrom" + -- "pyth_31" "pyth_sev" "pyth_third" NOT-JI + ]) + ,("Riley, Terry",words "riley_albion riley_rosary") + ,("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","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" + ,"wilcent17" + ,"wilson_alessandro" + ,"wilson_bag" + ,"wilson_class" + ,"wilson_dia1","wilson_dia2","wilson_dia3","wilson_dia4" + ,"wilson_duo" + ,"wilson_enh","wilson_enh2" + ,"wilson_facet" + -- ,"wilson_gh1","wilson_gh2","wilson_gh11","wilson_gh50" -- NON-JI + ,"wilson_hebdome1" + ,"wilson_hexflank" + ,"wilson_hypenh" + ,"wilson-rastbayyati24" + ,"wilson_l1","wilson_l2","wilson_l3","wilson_l4","wilson_l5","wilson_l6"]) + ,("Young, La Monte",["young-lm_guitar","young-lm_piano"]) + ] + +{- +import Music.Theory.Tuning.Scala +db <- scl_load_db +nm = concatMap snd scl_ji_au +scl = filter (\x -> scale_name x `elem` nm) db +non_ji = filter (not . scl_is_ji) scl +map scale_name non_ji +-} diff --git a/Music/Theory/Tuning/Scala/Mode.hs b/Music/Theory/Tuning/Scala/Mode.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Scala/Mode.hs @@ -0,0 +1,179 @@ +{- | 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 -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Function as Function {- hmt -} +import qualified Music.Theory.List as List {- hmt -} +import qualified Music.Theory.Tuning.Scala as Scala {- hmt -} + +-- | (mode-start-degree,mode-intervals,mode-description) +type Mode = (Int,[Int],String) + +-- | 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 + +-- | Intervals (in steps) between adjacent elements of the mode. +mode_intervals :: Mode -> [Int] +mode_intervals (_,i,_) = i + +-- | 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 + +-- | 'length' (or degree) of 'mode_intervals' (ie. number of notes in mode) +mode_length :: Mode -> Int +mode_length = length . mode_intervals + +-- | 'sum' of 'mode_intervals' (ie. number of notes in tuning system) +mode_univ :: Mode -> Int +mode_univ = sum . mode_intervals + +-- | '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 (_,_,m) x = filter ((== x) . mode_intervals) m + +-- | Expect /one/ result. +-- +-- > mn <- load_modenam +-- > let sq = putStrLn . unlines . mode_stat . fromJust . modenam_search_seq1 mn +-- > sq [2,2,1,2,2,2,1] +-- > sq [2,1,2,2,1,2,2] +-- > sq [2,1,2,2,1,3,1] +-- > sq (replicate 6 2) +-- > 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 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 (_,_,m) x = filter (isInfixOf x . mode_description) m + +-- | 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. +-- +-- > map non_implicit_degree ["4","[4]"] == [Nothing,Just 4] +non_implicit_degree :: String -> Maybe Int +non_implicit_degree s = + case List.unbracket s of + Just ('[',x,']') -> Just (read x) + _ -> Nothing + +-- | Predicate form +is_non_implicit_degree :: String -> Bool +is_non_implicit_degree = isJust . non_implicit_degree + +is_integer :: String -> Bool +is_integer = all isDigit + +parse_modenam_entry :: [String] -> Mode +parse_modenam_entry w = + 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] +join_long_lines l = + case l of + p:q:l' -> case List.separate_last' p of + (p',Just '\\') -> join_long_lines ((p' ++ q) : l') + _ -> p : join_long_lines (q : l') + _ -> l + +-- | Parse joined non-comment lines of modenam file. +parse_modenam :: [String] -> ModeNam +parse_modenam l = + case l of + n_str:x_str:m_str -> + let n = read n_str :: Int + x = read x_str :: Int + m = map (parse_modenam_entry . words) m_str + in if n == length m then (n,x,m) else error "parse_modenam" + _ -> error "parse_modenam" + +-- * Io + +{- | 'parse_modenam' of '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))) diff --git a/Music/Theory/Tuning/Sethares_1994.hs b/Music/Theory/Tuning/Sethares_1994.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Sethares_1994.hs @@ -0,0 +1,85 @@ +-- | William A. Sethares. +-- "Adaptive Tunings for Musical Scales". +-- /Journal of the Acoustical Society of America/, 96(1), July 1994. +module Music.Theory.Tuning.Sethares_1994 where + +import Data.Maybe {- base -} + +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" +MATLAB: + +> 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 + c1 = 5 + c2 = -5 + a1 = -3.51 + a2 = -5.75 + s = d_star / (s1 * min f1 f2 + s2) + f_dif = abs (f2 - f1) + e1 = c1 * exp (a1 * s * f_dif) + e2 = c2 * exp (a2 * s * f_dif) + in v1 * v2 * (e1 + e2) + +-- | 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 -> pl_dissonance (f,1) (f * r,1)) r_seq) f0 + +-- > 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" +-- +-- > 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 diff --git a/Music/Theory/Tuning/Syntonic.hs b/Music/Theory/Tuning/Syntonic.hs --- a/Music/Theory/Tuning/Syntonic.hs +++ b/Music/Theory/Tuning/Syntonic.hs @@ -3,10 +3,18 @@ import Data.List {- base -} -import Music.Theory.Tuning {- 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) @@ -18,12 +26,12 @@ -- | A minimal isomorphic note layout. -- -- > let [i,j,k] = mk_isomorphic_layout 3 5 (3,-4) --- > in [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout +-- > [i,take 4 j,(2,-4):take 4 k] == minimal_isomorphic_note_layout minimal_isomorphic_note_layout :: [[(Int,Int)]] minimal_isomorphic_note_layout = - [[(3,-4),(2,-2),(1,0),(0,2),(-1,4)] - ,[(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/. @@ -34,27 +42,27 @@ -- 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 in nub (sort (map (\x -> fromIntegral (x `mod` 1200)) (concat t))) --- | 'mk_syntonic_tuning' of @697@. --- --- > divisions syntonic_697 == 17 --- --- > let c = [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164] --- > in cents_i syntonic_697 == c -syntonic_697 :: Tuning -syntonic_697 = Tuning (Right (mk_syntonic_tuning 697)) 2 +{- | 'mk_syntonic_tuning' of @697@. +> tn_divisions syntonic_697 == 17 + +> let c = [0,79,194,273,309,388,467,503,582,697,776,812,891,970,1006,1085,1164] +> tn_cents_i syntonic_697 == c +-} +syntonic_697 :: T.Tuning +syntonic_697 = T.Tuning (Right (mk_syntonic_tuning 697)) Nothing + -- | 'mk_syntonic_tuning' of @702@. -- --- > divisions syntonic_702 == 17 +-- > tn_divisions syntonic_702 == 17 -- -- > let c = [0,24,114,204,294,318,408,498,522,612,702,792,816,906,996,1020,1110] --- > in cents_i syntonic_702 == c -syntonic_702 :: Tuning -syntonic_702 = Tuning (Right (mk_syntonic_tuning 702)) 2 - +-- > tn_cents_i syntonic_702 == c +syntonic_702 :: T.Tuning +syntonic_702 = T.Tuning (Right (mk_syntonic_tuning 702)) Nothing diff --git a/Music/Theory/Tuning/Type.hs b/Music/Theory/Tuning/Type.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Type.hs @@ -0,0 +1,166 @@ +-- | Tuning type +module Music.Theory.Tuning.Type where + +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.Either as T {- hmt -} +import qualified Music.Theory.Math.Prime as T {- hmt -} +import qualified Music.Theory.Tuning as T {- hmt -} + +-- * Tuning + +-- | A tuning specified 'Either' as a sequence of exact ratios, or as +-- a sequence of possibly inexact 'Cents', and an octave if not 2:1 or 1200. +-- +-- In both cases, the values are given in relation to the first degree +-- of the scale, which for ratios is 1 and for cents 0. +data Tuning = Tuning {tn_ratios_or_cents :: Either [Rational] [T.Cents] + ,tn_octave :: Maybe (Either Rational T.Cents)} + deriving (Eq,Show) + +-- | Default epsilon for recovering ratios from cents. +tn_epsilon :: Double +tn_epsilon = 0.001 + +-- | Tuning value as rational, reconstructed if required. +tn_as_ratio :: Double -> Either Rational T.Cents -> Rational +tn_as_ratio epsilon = either id (T.reconstructed_ratio epsilon) + +-- | Tuning value as cents. +tn_as_cents :: Either Rational T.Cents -> T.Cents +tn_as_cents = either T.ratio_to_cents id + +-- | Tuning octave, defaulting to 2:1. +tn_octave_def :: Tuning -> Either Rational T.Cents +tn_octave_def = fromMaybe (Left 2) . tn_octave + +-- | Tuning octave in cents. +tn_octave_cents :: Tuning -> T.Cents +tn_octave_cents = tn_as_cents . tn_octave_def + +-- | Tuning octave as ratio cents. +tn_octave_ratio :: Double -> Tuning -> Rational +tn_octave_ratio epsilon = tn_as_ratio epsilon . tn_octave_def + +-- | Divisions of octave. +-- +-- > tn_divisions (tn_equal_temperament 12) == 12 +tn_divisions :: Tuning -> Int +tn_divisions = either length length . tn_ratios_or_cents + +-- | 'Maybe' exact ratios of 'Tuning', NOT including the octave. +tn_ratios :: Tuning -> Maybe [Rational] +tn_ratios = T.from_left . tn_ratios_or_cents + +-- | Limit of JI tuning. +tn_limit :: Tuning -> Maybe Integer +tn_limit = fmap (maximum . map T.rational_prime_limit) . tn_ratios + +-- | 'error'ing variant. +tn_ratios_err :: Tuning -> [Rational] +tn_ratios_err = fromMaybe (error "ratios") . tn_ratios + +-- | Possibly inexact 'Cents' of tuning, NOT including the octave. +tn_cents :: Tuning -> [T.Cents] +tn_cents = either (map T.ratio_to_cents) id . tn_ratios_or_cents + +-- | 'map' 'round' '.' 'cents'. +tn_cents_i :: Integral i => Tuning -> [i] +tn_cents_i = map round . tn_cents + +-- | Variant of 'tn_cents' that includes octave at right. +tn_cents_octave :: Tuning -> [T.Cents] +tn_cents_octave t = tn_cents t ++ [tn_octave_cents t] + +-- | 'tn_cents' / 100 +tn_fmidi :: Tuning -> [Double] +tn_fmidi = map (* 0.01) . tn_cents + +-- | Possibly inexact 'Approximate_Ratio's of tuning. +tn_approximate_ratios :: Tuning -> [T.Approximate_Ratio] +tn_approximate_ratios = + either (map T.approximate_ratio) (map T.cents_to_fratio) . + tn_ratios_or_cents + +-- | Cyclic form, taking into consideration 'octave_ratio'. +tn_approximate_ratios_cyclic :: Tuning -> [T.Approximate_Ratio] +tn_approximate_ratios_cyclic t = + let r = tn_approximate_ratios t + m = T.cents_to_fratio (tn_octave_cents t) + g = iterate (* m) 1 + f n = map (* n) r + in concatMap f g + +-- | Lookup function that allows both negative & multiple octave indices. +-- +-- > :l Music.Theory.Tuning.DB.Werckmeister +-- > let map_zip f l = zip l (map f l) +-- > map_zip (tn_ratios_lookup werckmeister_vi) [-24 .. 24] +tn_ratios_lookup :: Tuning -> Int -> Maybe Rational +tn_ratios_lookup t n = + let (o,pc) = n `divMod` tn_divisions t + o_ratio = T.oct_diff_to_ratio (tn_octave_ratio tn_epsilon t) o + in fmap (\r -> o_ratio * (r !! pc)) (tn_ratios t) + +-- | Lookup function that allows both negative & multiple octave indices. +-- +-- > map_zip (tn_approximate_ratios_lookup werckmeister_v) [-24 .. 24] +tn_approximate_ratios_lookup :: Tuning -> Int -> T.Approximate_Ratio +tn_approximate_ratios_lookup t n = + let (o,pc) = n `divMod` tn_divisions t + o_ratio = fromRational (T.oct_diff_to_ratio (tn_octave_ratio tn_epsilon t) o) + in o_ratio * (tn_approximate_ratios t !! pc) + +-- | 'Maybe' exact ratios reconstructed from possibly inexact 'Cents' +-- of 'Tuning'. +-- +-- > :l Music.Theory.Tuning.DB.Werckmeister +-- > let r = [1,17/16,9/8,13/11,5/4,4/3,7/5,3/2,11/7,5/3,16/9,15/8] +-- > tn_reconstructed_ratios 1e-2 werckmeister_iii == Just r +tn_reconstructed_ratios :: Double -> Tuning -> Maybe [Rational] +tn_reconstructed_ratios epsilon = + fmap (map (T.reconstructed_ratio epsilon)) . + T.from_right . + tn_ratios_or_cents + +-- * Equal temperaments + +-- | Make /n/ division equal temperament. +tn_equal_temperament :: Integral n => n -> Tuning +tn_equal_temperament n = + let c = genericTake n [0,1200 / fromIntegral n ..] + in Tuning (Right c) Nothing + +-- | 12-tone equal temperament. +-- +-- > tn_cents tn_equal_temperament_12 == [0,100..1100] +tn_equal_temperament_12 :: Tuning +tn_equal_temperament_12 = tn_equal_temperament (12::Int) + +-- | 19-tone equal temperament. +-- +-- > let c = [0,63,126,189,253,316,379,442,505,568,632,695,758,821,884,947,1011,1074,1137] +-- > tn_cents_i tn_equal_temperament_19 == c +tn_equal_temperament_19 :: Tuning +tn_equal_temperament_19 = tn_equal_temperament (19::Int) + +-- | 31-tone equal temperament. +tn_equal_temperament_31 :: Tuning +tn_equal_temperament_31 = tn_equal_temperament (31::Int) + +-- | 53-tone equal temperament. +tn_equal_temperament_53 :: Tuning +tn_equal_temperament_53 = tn_equal_temperament (53::Int) + +-- | 72-tone equal temperament. +-- +-- > let r = [0,17,33,50,67,83,100] +-- > take 7 (map round (tn_cents tn_equal_temperament_72)) == r +tn_equal_temperament_72 :: Tuning +tn_equal_temperament_72 = tn_equal_temperament (72::Int) + +-- | 96-tone equal temperament. +tn_equal_temperament_96 :: Tuning +tn_equal_temperament_96 = tn_equal_temperament (96::Int) + diff --git a/Music/Theory/Tuning/Werckmeister.hs b/Music/Theory/Tuning/Werckmeister.hs deleted file mode 100644 --- a/Music/Theory/Tuning/Werckmeister.hs +++ /dev/null @@ -1,105 +0,0 @@ --- | Andreas Werckmeister (1645-1706). -module Music.Theory.Tuning.Werckmeister where - -import Music.Theory.Tuning {- hmt -} - --- | Approximate ratios for 'werckmeister_iii'. --- --- > let c = [0,90,192,294,390,498,588,696,792,888,996,1092] --- > in map (round . ratio_to_cents) werckmeister_iii_ar == c -werckmeister_iii_ar :: [Approximate_Ratio] -werckmeister_iii_ar = - let c0 = 2 ** (1/2) - c1 = 2 ** (1/4) - c2 = 8 ** (1/4) - in [1,256/243 - ,64/81 * c0,32/27 - ,256/243 * c1 - ,4/3,1024/729 - ,8/9 * c2,128/81 - ,1024/729 * c1,16/9 - ,128/81 * c1] - --- | Cents for 'werckmeister_iii'. -werckmeister_iii_ar_c :: [Cents] -werckmeister_iii_ar_c = map approximate_ratio_to_cents werckmeister_iii_ar - --- | Werckmeister III, Andreas Werckmeister (1645-1706) --- --- > cents_i werckmeister_iii == [0,90,192,294,390,498,588,696,792,888,996,1092] -werckmeister_iii :: Tuning -werckmeister_iii = Tuning (Right werckmeister_iii_ar_c) 2 - --- | Approximate ratios for 'werckmeister_iv'. --- --- > let c = [0,82,196,294,392,498,588,694,784,890,1004,1086] --- > in map (round . ratio_to_cents) werckmeister_iv_ar == c -werckmeister_iv_ar :: [Approximate_Ratio] -werckmeister_iv_ar = - let c0 = 2 ** (1/3) - c1 = 4 ** (1/3) - in [1,16384/19683 * c0 - ,8/9 * c0,32/27 - ,64/81 * c1 - ,4/3,1024/729 - ,32/27 * c0,8192/6561 * c0 - ,256/243 * c1,9/(4*c0) - ,4096/2187] - --- | Cents for 'werckmeister_iv'. -werckmeister_iv_c :: [Cents] -werckmeister_iv_c = map approximate_ratio_to_cents werckmeister_iv_ar - --- | Werckmeister IV, Andreas Werckmeister (1645-1706) --- --- > cents_i werckmeister_iv == [0,82,196,294,392,498,588,694,784,890,1004,1086] -werckmeister_iv :: Tuning -werckmeister_iv = Tuning (Right werckmeister_iv_c) 2 - --- | Approximate ratios for 'werckmeister_v'. --- --- > let c = [0,96,204,300,396,504,600,702,792,900,1002,1098] --- > in map (round . ratio_to_cents) werckmeister_v_ar == c -werckmeister_v_ar :: [Approximate_Ratio] -werckmeister_v_ar = - let c0 = 2 ** (1/4) - c1 = 2 ** (1/2) - c2 = 8 ** (1/4) - in [1,8/9 * c0 - ,9/8,c0 - ,8/9 * c1 - ,9/8 * c0,c1 - ,3/2,128/81 - ,c2,3/c2 - ,4/3 * c1] - --- | Cents for 'werckmeister_v'. -werckmeister_v_c :: [Cents] -werckmeister_v_c = map approximate_ratio_to_cents werckmeister_v_ar - --- | Werckmeister V, Andreas Werckmeister (1645-1706) --- --- > cents_i werckmeister_v == [0,96,204,300,396,504,600,702,792,900,1002,1098] -werckmeister_v :: Tuning -werckmeister_v = Tuning (Right werckmeister_v_c) 2 - --- | Ratios for 'werckmeister_vi'. --- --- > let c = [0,91,196,298,395,498,595,698,793,893,1000,1097] --- > in map (round . ratio_to_cents) werckmeister_vi_r == c -werckmeister_vi_r :: [Rational] -werckmeister_vi_r = - [1,98/93 - ,28/25,196/165 - ,49/39 - ,4/3,196/139 - ,196/131,49/31 - ,196/117,98/55 - ,49/26] - --- | Werckmeister VI, Andreas Werckmeister (1645-1706) --- --- > cents_i werckmeister_vi == [0,91,196,298,395,498,595,698,793,893,1000,1097] -werckmeister_vi :: Tuning -werckmeister_vi = Tuning (Left werckmeister_vi_r) 2 - diff --git a/Music/Theory/Tuning/Wilson.hs b/Music/Theory/Tuning/Wilson.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Tuning/Wilson.hs @@ -0,0 +1,936 @@ +-- | Erv Wilson, archives +module Music.Theory.Tuning.Wilson where + +import Control.Monad {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ord {- base -} +import Data.Ratio {- base -} +import Text.Printf {- base -} + +import qualified Safe {- safe -} + +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) +v2_zip :: (a -> b -> c) -> V2 a -> V2 b -> V2 c +v2_zip f (i,j) (p,q) = (f i p,f j q) +v2_add :: Num n => V2 n -> V2 n -> V2 n +v2_add = v2_zip (+) +v2_sum :: Num n => [V2 n] -> V2 n +v2_sum = foldl v2_add (0,0) +v2_scale :: Num n => n -> V2 n -> V2 n +v2_scale n = v2_map (* n) + +-- * Pt Set + +{- | Normalise set of points to lie in (-1,-1) - (1,1), scaling symetrically about (0,0) + +> pt_set_normalise_sym [(40,0),(0,40),(13,11),(-8,4)] == [(1,0),(0,1),(0.325,0.275),(-0.2,0.1)] +> pt_set_normalise_sym [(-10,0),(1,10)] == [(-1,0),(0.1,1)] +-} +pt_set_normalise_sym :: (Fractional n,Ord n) => [V2 n] -> [V2 n] +pt_set_normalise_sym x = + let z = maximum (map (uncurry max . Function.bimap1 abs) x) + in map (v2_scale (recip z)) x + +-- * Lattice Design + +-- | /k/-unit co-ordinates for /k/-lattice. +type Lattice_Design n = (Int,[V2 n]) + +-- | Erv Wilson standard lattice, unit co-ordinates for 5-dimensions, ie. [3,5,7,11,13] +-- +-- +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] +-- +-- +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 (3-lattice), used especially when working with hexanies or 7 limit tunings +-- +-- +ew_lc_tetradic :: Num n => Lattice_Design n +ew_lc_tetradic = (3,[(-4,-2),(6,1),(5,-2)]) + +-- * Lattice_Factors + +-- | A discrete /k/-lattice is described by a sequence of /k/-factors. +-- 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 Lattice_Position = (Int,[Int]) + +-- | 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 (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 Lattice_Factors [X,Y,Z..] and Lattice_Position [x,y,z..], calculate the indicated ratio. +-- +-- > 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 ^ Convert.int_to_integer j) % 1 + EQ -> 1 + LT -> 1 % (i ^ abs (Convert.int_to_integer j)) + in product (zipWith f p q) + +-- * Rat (n,d) + +-- | Ratio given as (/n/,/d/) +type Rat = (Integer,Integer) + +-- | Remove all octaves from /n/ and /d/. +rat_rem_oct :: Rat -> Rat +rat_rem_oct = 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 . Math.rational_nd + +-- | 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 (n1,d1) (n2,d2) = (n1 + n2,d1 + d2) + +-- | Rat written as n/d +rat_pp :: Rat -> String +rat_pp (n,d) = concat [show n,"/",show d] + +-- * Rational + +-- | Lifted 'rat_rem_oct'. +-- +-- > map ew_r_rem_oct [256/243,7/5,1/7] == [1/243,7/5,1/7] +r_rem_oct :: Rational -> Rational +r_rem_oct = rat_lift_1 rat_rem_oct + +-- | Assert that /n/ is in [1,2). +r_verify_oct :: Rational -> Rational +r_verify_oct i = if i >= 1 && i < 2 then i else error (show ("r_verify_oct?",i)) + +-- | Find limit of set of ratios, ie. largest factor in either numerator or denominator. +-- +-- > r_seq_limit [1] == 1 +r_seq_limit :: [Rational] -> Integer +r_seq_limit = maximum . map 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 + +-- | 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 :: Bool -> Integer -> [Rational] -> [[String]] +tbl_txt del lm_z rs = + let lm = r_seq_limit rs + 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 "..." + ,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 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 (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 (lc_m,_,_) = isJust lc_m + +-- > 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 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 + +-- | '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,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) -> List.mcons (p_f v) [("label",v_pp v)] + ,const []) + +-- | '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 -> Graph.Lbl Rational () -> IO () +ew_gr_udot_wr_svg opt fn gr = do + ew_gr_udot_wr opt fn gr + void (Dot.dot_to_svg (if ew_gr_opt_pos opt then ["-n"] else []) fn) + +-- * Zig-Zag + +zz_seq_1 :: (Eq n,Num n) => Int -> (n,n) -> (n,n) -> [(n,n)] +zz_seq_1 k (p,q) (n,d) = if k == 0 then [(n,d)] else (n,d) : zz_seq_1 (k - 1) (p,q) (n+p,d+q) + +-- > zz_next 3 [(0,1),(1,1)] == [(1,1),(1,2),(1,3),(1,4)] +zz_next :: (Eq n, Num n) => Int -> [(n,n)] -> [(n,n)] +zz_next k p = + case reverse p of + i:j:_ -> zz_seq_1 k j i + _ -> error "zz_next?" + +zz_recur :: (Eq n, Num n) => [Int] -> [(n,n)] -> [[(n,n)]] +zz_recur k_seq p = + case k_seq of + [] -> [] + k:k_rem -> let r = zz_next k p in r : zz_recur k_rem r + +-- > zz_seq [3,9,2,2,4,6,2,1,1,3] +-- > zz_seq [2,4,2,158] +-- > zz_seq [1,1,4,2,1,3,1,6,2] +zz_seq :: (Eq n, Num n) => [Int] -> [[(n, n)]] +zz_seq k_seq = zz_recur k_seq [(0,1),(1,1)] + +-- * Mos + +-- > gen_coprime 12 == [1,5] +-- > gen_coprime 49 == [1..24] \\ [7,14,21] +gen_coprime :: Integral a => a -> [a] +gen_coprime x = filter (\y -> gcd y x == 1) [1 .. (x `div` 2)] + +-- > mos_2 12 5 == (5,7) +mos_2 :: Num n => n -> n -> (n,n) +mos_2 p g = (g,p - g) + +-- | Divide MOS, keeps retained value on same side +-- +-- > mos_step (5,7) == (5,2) +-- > mos_step (5,2) == (3,2) +-- > mos_step (3,2) == (1,2) +mos_step :: (Ord a, Num a) => (a, a) -> (a, a) +mos_step (i,j) = if i < j then (i,j - i) else (i - j,j) + +-- > mos_unfold (5,7) == [(5,7),(5,2),(3,2),(1,2)] +-- > mos_unfold (41,17) == [(41,17),(24,17),(7,17),(7,10),(7,3),(4,3),(1,3),(1,2)] +mos_unfold :: (Ord b, Num b) => (b, b) -> [(b, b)] +mos_unfold x = + let y = mos_step x + in if Tuple.t2_sum y == 3 then [x,y] else x : mos_unfold y + +mos_verify :: Integral a => a -> a -> Bool +mos_verify p g = + let x = if g > (p `div` 2) then p `mod` g else g + in x `elem` gen_coprime p + +-- > mos 12 5 == [(5,7),(5,2),(3,2),(1,2)] +mos :: (Ord b, Integral b) => b -> b -> [(b, b)] +mos p g = if mos_verify p g then mos_unfold (mos_2 p g) else error "mos?" + +-- > mos_seq 12 5 == [[5,7],[5,5,2],[3,2,3,2,2],[1,2,2,1,2,2,2]] +-- > mos_seq 41 17 !! 4 == [3,3,4,3,4,3,3,4,3,4,3,4] +-- > map length (mos_seq 49 27) == [2,3,5,7,9,11,20,29] +mos_seq :: (Ord b, Integral b) => b -> b -> [[b]] +mos_seq p g = + let step_f (i,j) = concatMap (\x -> if x == i + j then [i,j] else [x]) + recur_f x l = if null x then [l] else l : recur_f (tail x) (step_f (head x) l) + ((i0,j0), r) = List.headTail (mos p g) + in recur_f r [i0,j0] + +mos_cell_pp :: (Integral i,Show i) => i -> String +mos_cell_pp x = let s = show x in s ++ genericReplicate (x - genericLength s) '-' + +mos_row_pp :: (Integral i,Show i) => [i] -> String +mos_row_pp = concatMap mos_cell_pp + +mos_tbl_pp :: (Integral i,Show i) => [[i]] -> [String] +mos_tbl_pp = map mos_row_pp + +-- > mos_tbl_wr (mos_seq 49 27) +mos_tbl_wr :: (Integral i,Show i) => [[i]] -> IO () +mos_tbl_wr = putStrLn . unlines . mos_tbl_pp + +-- * Mos/Log + +mos_recip_seq :: Double -> [(Int,Double)] +mos_recip_seq x = let y = truncate x in (y,x) : mos_recip_seq (recip (x - fromIntegral y)) + +-- > take 3 (mos_log (5/4)) == [(3,3.10628371950539),(9,9.408778735385603),(2,2.4463112031908785)] +mos_log :: Double -> [(Int,Double)] +mos_log r = mos_recip_seq (recip (logBase 2 r)) + +-- > take 9 (mos_log_kseq 1.465571232) == [1,1,4,2,1,3,1,6,2] +mos_log_kseq :: Double -> [Int] +mos_log_kseq = map fst . mos_log + +-- * Stern-Brocot Tree + +data SBT_DIV = NIL | LHS | RHS deriving (Show) +type Sbt_Node = (SBT_DIV,Rat,Rat,Rat) + +sbt_step :: Sbt_Node -> [Sbt_Node] +sbt_step (_,l,m,r) = [(LHS,l,rat_mediant l m, m),(RHS,m,rat_mediant m r,r)] + +-- sbt = stern-brocot tree +sbt_root :: Sbt_Node +sbt_root = (NIL,(0,1),(1,1),(1,0)) + +sbt_half :: Sbt_Node +sbt_half = (NIL,(0,1),(1,2),(1,1)) + +-- > sbt_from sbt_root +sbt_from :: Sbt_Node -> [[Sbt_Node]] +sbt_from = iterate (concatMap sbt_step) . return + +sbt_k_from :: Int -> Sbt_Node -> [[Sbt_Node]] +sbt_k_from k = take k . sbt_from + +sbt_node_to_edge :: Sbt_Node -> String +sbt_node_to_edge (dv,l,m,r) = + let edge_pp p q = printf "\"%s\" -- \"%s\"" (rat_pp p) (rat_pp q) + in case dv of + NIL -> "" + LHS -> edge_pp r m + RHS -> edge_pp l m + +sbt_node_elem :: Sbt_Node -> [Rat] +sbt_node_elem (dv,l,m,r) = + case dv of + NIL -> [l,m,r] + _ -> [m] + +sbt_dot :: [Sbt_Node] -> [String] +sbt_dot n = + let e = map sbt_node_to_edge n + in concat [["graph {","node [shape=plain]"],e,["}"]] + +-- * M-Gen + +(^.) :: Rational -> Int -> Rational +(^.) = (^) + +r_normalise :: [Rational] -> [Rational] +r_normalise = nub . sortOn Tuning.fold_ratio_to_octave_err + +-- | (ratio,multiplier,steps) +type M_Gen = (Rational,Rational,Int) + +m_gen_unfold :: M_Gen -> [Rational] +m_gen_unfold (r,m,n) = take n (iterate (* m) r) + +m_gen_to_r :: [M_Gen] -> [Rational] +m_gen_to_r = r_normalise . concatMap m_gen_unfold + +-- * M3-Gen + +-- | (ratio,M3-steps) +type M3_Gen = (Rational,Int) + +m3_to_m :: M3_Gen -> M_Gen +m3_to_m (r,n) = (r,3,n) + +-- > map m3_gen_unfold [(3,4),(21/9,4),(15/9,4),(35/9,3),(21/5,4),(27/5,3)] +m3_gen_unfold :: M3_Gen -> [Rational] +m3_gen_unfold = m_gen_unfold . m3_to_m + +m3_gen_to_r :: [M3_Gen] -> [Rational] +m3_gen_to_r = r_normalise . concatMap m3_gen_unfold + +-- * Scala + +r_to_scale :: String -> String -> [Rational] -> Scala.Scale +r_to_scale nm dsc 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] -> [Scala.Scale] -> [String] +ew_scl_find_r r = + let set_eq x y = sort x == sort y + 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]) + +-- * + +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} + +> 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 :: 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) + +-- * + +{- | P.7 11-limit {Scala=nil} + +> 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 :: 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} + +> 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 :: 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} + +> 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 :: Scala.Scale +ew_el12_12_scl = r_to_scale "ew_el12_12" "EW, earlylattices12.pdf, P.12" ew_el12_12_r + +-- * + +{- | P.2 11-limit {Scala=wilson_l4} + +> ew_scl_find_r ew_el22_2_r 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} + +> 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} + +> 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} + +> 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} + +> ew_scl_find_r ew_el22_6_r db +-} +ew_el22_6_r :: [Rational] +ew_el22_6_r = + [1,7*7/3,7*11/(3*3),11/5,3*3,7/3,7*11,5,7*11/(3*5),1/3,11 + ,7*11/(3*3*3),5*7/3,3,11/7,7*11/3,5/3,7*11/(3*3*5),7,11/3,3*5,7*11/5] + +-- * + +ew_diamond_mk :: [Integer] -> [Rational] +ew_diamond_mk u = r_normalise [x % y | x <- u, y <- u] + +-- > m3_gen_to_r ew_diamond_12_gen == ew_diamond_12_r +ew_diamond_12_gen :: [M3_Gen] +ew_diamond_12_gen = + [(1/(3^.2),5),(5/(3^.2),3),(7/(3^.2),3),(11/(3^.2),3) + ,(1/5,3),(1/7,3),(1/11,3) + ,(5/7,1),(5/11,1),(7/5,1),(7/11,1),(11/5,1),(11/7,1)] + +{- | P.7 & P.12 11-limit {Scala=partch_29} + +1,3,5,7,9,11 diamond + +> ew_scl_find_r ew_diamond_12_r 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} + +1,3,5,7,9,11,13,15 diamond + +> 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] + +-- * + +hel_r_asc :: (Integer,Integer) -> [Rational] +hel_r_asc (n,d) = n%d : hel_r_asc (n+1,d+1) + +type HEL = ([Rational],[Rational]) + +-- | P.6 +hel_1_i :: HEL +hel_1_i = + let i = take 6 (hel_r_asc (7,6)) + in (take 5 i,take 5 (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 (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 (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} + +22-tone 23-limit Evangalina tuning (2001) + +> 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 :: Scala.Scale +ew_hel_12_scl = r_to_scale "ew_hel_12" "EW, hel.pdf, P.12" ew_hel_12_r + +-- * + +-- > she_div "ABCD" == [["BCD","A"],["ACD","B"],["ABD","C"],["ABC","D"]] +she_div :: Eq a => [a] -> [[[a]]] +she_div x = + let f = (== [1,length x - 1]) . sort . map length + in map (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] +she_div_r = + let f x = + case x of + [[a,b,c],[d]] -> (a * b * c) / d + _ -> error "she_div?" + in map f . she_div + +-- > she_mul_r [1,3,5,7] == [1,3,5,7,9,15,21,25,35,49] +she_mul_r :: [Rational] -> [Rational] +she_mul_r r = [x * y | x <- r,y <- r,x <= y] + +{- | she = Stellate Hexany Expansions, P.10 {Scala=stelhex1,stelhex2,stelhex5,stelhex6} + +> she [1,3,5,7] == [1,21/20,15/14,35/32,9/8,5/4,21/16,35/24,3/2,49/32,25/16,105/64,7/4,15/8] +> mapM (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 Tuning.fold_ratio_to_octave_err (she_mul_r r ++ she_div_r r))) + +-- * + +-- > map (every_nth "abcdef") [1..3] == ["abcdef","ace","ad"] +every_nth :: [t] -> Int -> [t] +every_nth l k = + case l of + [] -> [] + x:_ -> x : every_nth (drop k l) k + +meru :: Num n => [[n]] +meru = + let f xs = zipWith (+) (0 : xs) (xs ++ [0]) + in iterate f [1] + +-- > meru_k 13 +meru_k :: Num n => Int -> [[n]] +meru_k k = take k meru + +-- > map (sum . meru_1) [1 .. 13] == [1,1,2,3,5,8,13,21,34,55,89,144,233] +meru_1 :: Num n => Int -> [n] +meru_1 k = zipWith (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 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 (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 = OEIS.a000930 + +-- | meru_3 = META-SLENDRO +meru_3 :: Num n => Int -> [[n]] +meru_3 k = + 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] + +-- > map sum (meru_3_seq 13) == [1,0,1,1,1,2,2,3,4,5,7,9,12,16,21,28,37,49,65,86,114,151,200,265,351,465] +meru_3_seq :: Num n => Int -> [[n]] +meru_3_seq k = concatMap meru_3 [1 .. k] + +-- > take 26 meru_3_direct == [1,0,1,1,1,2,2,3,4,5,7,9,12,16,21,28,37,49,65,86,114,151,200,265,351,465] +meru_3_direct :: Num n => [n] +meru_3_direct = drop 3 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 (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 OEIS.a003269 + +-- > map meru_5 [1..4] +meru_5 :: Num n => Int -> [[n]] +meru_5 k = + 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] + +-- > map sum (meru_5_seq 13) +meru_5_seq :: Num n => Int -> [[n]] +meru_5_seq k = concatMap meru_5 [1 .. k] + +-- > take 39 meru_5_direct == map sum (meru_5_seq 13) +meru_5_direct :: Num n => [n] +meru_5_direct = 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 (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 = 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 = OEIS.a001687 + +-- * + +{- | P.13, tanabe {Scala=chin_7} + +> 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] + +-- * (Novaro) + +ew_novarotreediamond_1 :: ([[Rational]],[[Rational]]) +ew_novarotreediamond_1 = + 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 = 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 = List.rotations i_0 + in (i,map i_to_r i) + +{- | P.1 {Scala=nil} + +23-tone 7-limit (2004) + +> ew_scl_find_r ew_novarotreediamond_1_r db +-} +ew_novarotreediamond_1_r :: [Rational] +ew_novarotreediamond_1_r = r_normalise (concat (snd ew_novarotreediamond_1)) + +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 + +-- * + +{- | P.2 {Scala=nil} + +9-tone Pelog cycle (1988) + +> 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 :: Scala.Scale +ew_Pelogflute_2_scl = r_to_scale "ew_Pelogflute_2" "EW, Pelogflute.pdf, P.2" ew_Pelogflute_2_r + + +-- * + +-- | P.9, Fig. 3 +xen1_fig3 :: (Sbt_Node,Int) +xen1_fig3 = ((NIL,(1,3),(2,5),(1,2)),5) + +-- | P.9, Fig. 4 +xen1_fig4 :: (Sbt_Node,Int) +xen1_fig4 = ((NIL,(2,5),(5,12),(3,7)),5) + +-- * + +-- | P.3 Turkisk Baglama Scale {11-limit, Scala=nil} +ew_xen3b_3_gen :: [(Rational,Int)] +ew_xen3b_3_gen = [(1/(3^.6),12),(1/11,2),(5/3,3)] + +ew_xen3b_3_r :: [Rational] +ew_xen3b_3_r = m3_gen_to_r ew_xen3b_3_gen + +ew_xen3b_3_scl :: 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] +xen3b_9_i :: [[Rational]] +xen3b_9_i = + [[6/5, 10/9, 9/8, 6/5, 10/9] + ,[16/15,9/8, 10/9, 9/8, 16/15,9/8, 10/9] + ,[16/15,135/128,16/15, 25/24,16/15, 16/15,135/128, 16/15,135/128,16/15, 25/24,16/15] + ,[28/27,36/35,135/128,28/27,36/35, 25/24,28/27,36/35, 28/27,36/35,135/128, 28/27,36/35,135/128,28/27,36/35, 25/24,28/27,36/35] + ,[64/63,49/48,36/35,45/44,33/32,64/63,49/48,36/35, 45/44,55/54,64/63,49/48,36/35, 64/63,49/48,36/35,45/44,33/32, 64/63,49/48,36/35,45/44,33/32,64/63,49/48,36/35, 45/44,55/54,64/63,49/48,36/35]] + +{- | P.9 {SCALA 5=nil 7=ptolemy_idiat 12=nil 19=wilson2 31=wilson_31} + +> mapM ew_scl_find_r xen3b_9_r db +-} +xen3b_9_r :: [[Rational]] +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]] +xen3b_13_i = + [[7/6, 8/7, 9/8, 7/6, 8/7] + ,[28/27,9/8, 8/7, 9/8, 28/27,9/8, 8/7] + ,[28/27,243/224,28/27, 10/9,36/35, 28/27,243/224, 28/27,243/224,28/27, 10/9,36/35] + ,[28/27,36/35,135/128,28/27, 36/35,175/162,36/35, 28/27,36/35,135/128, 28/27,36/35,135/128,28/27, 36/35,175/162,36/35] + ,[28/27,36/35,25/24,81/80,28/27, 36/35,25/24,28/27,36/35, 28/27,36/35,25/24,81/80, 28/27,36/35,25/24,81/80,28/27, 36/35,25/24,28/27,36/35]] + +-- | P.13 {SCALA 5=slendro5_2 7=ptolemy_diat2 12=nil 17=nil 22=wilson7_4} +xen3b_13_r :: [[Rational]] +xen3b_13_r = map (List.drop_last . scanl (*) 1) xen3b_13_i + +-- * + +{- | PP.1-2 {SCALA: 22=wilson7_4} + +17,31,41 lattices from XEN3B (1975) +-} +ew_xen3b_apx_gen :: [(Int,[M3_Gen])] +ew_xen3b_apx_gen = + [(17,[(1/729,12) + ,(5/3,3) + ,(11,2)]) + ,(31,[(1/3,5) + ,(5,2),(1/(5*(3^.2)),5) + ,(7/(3^.4),5),(1/(7*(3^.4)),5) + ,(1/11,5) + ,((1/3)*(1/7)*5,2) + ,((1/(7*(3^.3))) * 5,2)]) + ,(41,[(1/(3^.6),12) + ,(5/(3^.3),5),(1/(5*(3^.2)),5) + ,(7/(3^.4),7),(1/(7*(3^.3)),7) + ,(11,5)]) + ,(22,[(1/3,5) + ,(5/(3^.3),5),(1/(5*(3^.2)),5) + ,(7/(3^.4),5) + ,(7/(3^.3)*5,2)])] + +ew_xen3b_apx_r :: [(Int,[Rational])] +ew_xen3b_apx_r = + let f (k,g) = (k,r_normalise (concatMap m3_gen_unfold g)) + in map f ew_xen3b_apx_gen + +-- * + +ew_xen456_7_gen :: [M3_Gen] +ew_xen456_7_gen = [(25/24,4),(5/3,4),(4/3,4),(16/15,4),(32/25,3)] + +{- P.7 {Scala=wilson1} + +19-tone "A Scale for Scott" (1976) + +> 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 = + [(1/(3^.3),4) + ,(1/(5*(3^.2)),3) + ,(1/(7*3),3) + ,(1/11,3) + ,(5/(11*3),4) + ,(7/11,2)] + +{- | P.9 {Scala=nil ; Scala:Rot=wilson11} + +19-tone scale for the Clavichord-19 (1976) + +> ew_scl_find_r ew_xen456_9_r db + +> 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 :: Scala.Scale +ew_xen456_9_scl = r_to_scale "ew_xen456_9" "EW, xen456.pdf, P.9" ew_xen456_9_r + +-- * Gems + +{- | + +13-limit 22-tone scale {Scala=nil} + +> ew_scl_find_r ew_poole_r 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 :: Scala.Scale +ew_poole_scl = r_to_scale "ew_poole" "EW, 2010/10/scale-for-rod-poole.html" ew_poole_r + +{- | + +11-limit 17-tone scale {Scala=wilcent17} + +> ew_scl_find_r ew_centaur17_r 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] + +{- | + +7-limit 22-tone scale {Scala=nil} + +> ew_scl_find_r ew_two_22_7_r db +-} +ew_two_22_7_r :: [Rational] +ew_two_22_7_r = + [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 :: 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 + +{- | Scales /not/ present in the standard scala file set. + +> mapM_ (Scala.scale_wr_dir "/home/rohan/sw/hmt/data/scl/") ew_scl_db +> map Scala.scale_name ew_scl_db +-} +ew_scl_db :: [Scala.Scale] +ew_scl_db = + [ew_1357_3_scl + ,ew_el12_7_scl + ,ew_el12_12_scl + ,ew_hel_12_scl + ,ew_novarotreediamond_1_scl + ,ew_Pelogflute_2_scl + ,ew_xen3b_3_scl + ,ew_xen456_9_scl + ,ew_poole_scl + ,ew_two_22_7_scl + ] + +-- Local Variables: +-- truncate-lines:t +-- End: diff --git a/Music/Theory/Tuple.hs b/Music/Theory/Tuple.hs deleted file mode 100644 --- a/Music/Theory/Tuple.hs +++ /dev/null @@ -1,258 +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 - -import Data.Monoid {- base -} - --- * P2 (2 product) - -p2_swap :: (s,t) -> (t,s) -p2_swap (i,j) = (j,i) - --- * T2 (2-tuple, regular) - --- | Uniform two-tuple. -type T2 a = (a,a) - -t2 :: [t] -> T2 t -t2 l = case l of {[p,q] -> (p,q);_ -> error "t2"} - -t2_list :: T2 a -> [a] -t2_list (i,j) = [i,j] - -t2_swap :: T2 t -> T2 t -t2_swap = p2_swap - -t2_map :: (p -> q) -> T2 p -> T2 q -t2_map f (p,q) = (f p,f q) - -t2_zipWith :: (p -> q -> r) -> T2 p -> T2 q -> T2 r -t2_zipWith f (p,q) (p',q') = (f p p',f q q') - -t2_infix :: (a -> a -> b) -> T2 a -> b -t2_infix f (i,j) = i `f` j - --- | Infix 'mappend'. --- --- > t2_join ([1,2],[3,4]) == [1,2,3,4] -t2_join :: Monoid m => T2 m -> m -t2_join = t2_infix mappend - -t2_concat :: [T2 [a]] -> T2 [a] -t2_concat = t2_map mconcat . unzip - -t2_sort :: Ord t => (t,t) -> (t,t) -t2_sort (p,q) = (min p q,max p q) - --- * P3 (3 product) - --- | Left rotation. --- --- > p3_rotate_left (1,2,3) == (2,3,1) -p3_rotate_left :: (s,t,u) -> (t,u,s) -p3_rotate_left (i,j,k) = (j,k,i) - -p3_fst :: (a,b,c) -> a -p3_fst (a,_,_) = a - -p3_snd :: (a,b,c) -> b -p3_snd (_,b,_) = b - -p3_third :: (a,b,c) -> c -p3_third (_,_,c) = c - --- * T3 (3 triple, regular) - -type T3 a = (a,a,a) - -t3 :: [t] -> T3 t -t3 l = case l of {[p,q,r] -> (p,q,r);_ -> error "t3"} - -t3_rotate_left :: T3 t -> T3 t -t3_rotate_left = p3_rotate_left - -t3_fst :: T3 t -> t -t3_fst = p3_fst - -t3_snd :: T3 t -> t -t3_snd = p3_snd - -t3_third :: T3 t -> t -t3_third = p3_third - -t3_map :: (p -> q) -> T3 p -> T3 q -t3_map f (p,q,r) = (f p,f q,f r) - -t3_zipWith :: (p -> q -> r) -> T3 p -> T3 q -> T3 r -t3_zipWith f (p,q,r) (p',q',r') = (f p p',f q q',f r r') -t3_list :: T3 a -> [a] -t3_list (i,j,k) = [i,j,k] - -t3_infix :: (a -> a -> a) -> T3 a -> a -t3_infix f (i,j,k) = (i `f` j) `f` k - -t3_join :: T3 [a] -> [a] -t3_join = t3_infix (++) - --- * P4 (4 product) - -p4_fst :: (a,b,c,d) -> a -p4_fst (a,_,_,_) = a - -p4_snd :: (a,b,c,d) -> b -p4_snd (_,b,_,_) = b - -p4_third :: (a,b,c,d) -> c -p4_third (_,_,c,_) = c - -p4_fourth :: (a,b,c,d) -> d -p4_fourth (_,_,_,d) = d - --- * T4 (4-tuple, regular) - -type T4 a = (a,a,a,a) - -t4 :: [t] -> T4 t -t4 l = case l of {[p,q,r,s] -> (p,q,r,s); _ -> error "t4"} - -t4_list :: T4 t -> [t] -t4_list (p,q,r,s) = [p,q,r,s] - -t4_fst :: T4 t -> t -t4_fst = p4_fst - -t4_snd :: T4 t -> t -t4_snd = p4_snd - -t4_third :: T4 t -> t -t4_third = p4_third - -t4_fourth :: T4 t -> t -t4_fourth = p4_fourth - -t4_map :: (p -> q) -> T4 p -> T4 q -t4_map f (p,q,r,s) = (f p,f q,f r,f s) - -t4_zipWith :: (p -> q -> r) -> T4 p -> T4 q -> T4 r -t4_zipWith f (p,q,r,s) (p',q',r',s') = (f p p',f q q',f r r',f s s') - -t4_infix :: (a -> a -> a) -> T4 a -> a -t4_infix f (i,j,k,l) = ((i `f` j) `f` k) `f` l - -t4_join :: T4 [a] -> [a] -t4_join = t4_infix (++) - --- * P5 (5 product) - -p5_fst :: (a,b,c,d,e) -> a -p5_fst (a,_,_,_,_) = a - -p5_snd :: (a,b,c,d,e) -> b -p5_snd (_,b,_,_,_) = b - -p5_third :: (a,b,c,d,e) -> c -p5_third (_,_,c,_,_) = c - -p5_fourth :: (a,b,c,d,e) -> d -p5_fourth (_,_,_,d,_) = d - -p5_fifth :: (a,b,c,d,e) -> e -p5_fifth (_,_,_,_,e) = e - --- * T5 (5-tuple, regular) - -type T5 a = (a,a,a,a,a) - -t5 :: [t] -> T5 t -t5 l = case l of {[p,q,r,s,t] -> (p,q,r,s,t); _ -> error "t5"} - -t5_list :: T5 t -> [t] -t5_list (p,q,r,s,t) = [p,q,r,s,t] - -t5_map :: (p -> q) -> T5 p -> T5 q -t5_map f (p,q,r,s,t) = (f p,f q,f r,f s,f t) - -t5_fst :: T5 t -> t -t5_fst (p,_,_,_,_) = p - -t5_snd :: T5 t -> t -t5_snd (_,q,_,_,_) = q - -t5_fourth :: T5 t -> t -t5_fourth (_,_,_,t,_) = t - -t5_fifth :: T5 t -> t -t5_fifth (_,_,_,_,u) = u - -t5_infix :: (a -> a -> a) -> T5 a -> a -t5_infix f (i,j,k,l,m) = (((i `f` j) `f` k) `f` l) `f` m - -t5_join :: T5 [a] -> [a] -t5_join = t5_infix (++) - --- * P6 (6 product) - -p6_fst :: (a,b,c,d,e,f) -> a -p6_fst (a,_,_,_,_,_) = a - -p6_snd :: (a,b,c,d,e,f) -> b -p6_snd (_,b,_,_,_,_) = b - -p6_third :: (a,b,c,d,e,f) -> c -p6_third (_,_,c,_,_,_) = c - -p6_fourth :: (a,b,c,d,e,f) -> d -p6_fourth (_,_,_,d,_,_) = d - -p6_fifth :: (a,b,c,d,e,f) -> e -p6_fifth (_,_,_,_,e,_) = e - -p6_sixth :: (a,b,c,d,e,f) -> f -p6_sixth (_,_,_,_,_,f) = f - --- * T6 (6-tuple, regular) - -type T6 a = (a,a,a,a,a,a) - -t6 :: [t] -> T6 t -t6 l = case l of {[p,q,r,s,t,u] -> (p,q,r,s,t,u);_ -> error "t6"} - -t6_list :: T6 t -> [t] -t6_list (p,q,r,s,t,u) = [p,q,r,s,t,u] - -t6_map :: (p -> q) -> T6 p -> T6 q -t6_map f (p,q,r,s,t,u) = (f p,f q,f r,f s,f t,f u) - --- * T7 (7-tuple, regular) - -type T7 a = (a,a,a,a,a,a,a) - -t7_list :: T7 t -> [t] -t7_list (p,q,r,s,t,u,v) = [p,q,r,s,t,u,v] - -t7_map :: (p -> q) -> T7 p -> T7 q -t7_map f (p,q,r,s,t,u,v) = (f p,f q,f r,f s,f t,f u,f v) - --- * T8 (8-tuple, regular) - -type T8 a = (a,a,a,a,a,a,a,a) - -t8_list :: T8 t -> [t] -t8_list (p,q,r,s,t,u,v,w) = [p,q,r,s,t,u,v,w] - -t8_map :: (p -> q) -> T8 p -> T8 q -t8_map f (p,q,r,s,t,u,v,w) = (f p,f q,f r,f s,f t,f u,f v,f w) - --- * T9 (9-tuple, regular) - -type T9 a = (a,a,a,a,a,a,a,a,a) - -t9_list :: T9 t -> [t] -t9_list (p,q,r,s,t,u,v,w,x) = [p,q,r,s,t,u,v,w,x] - -t9_map :: (p -> q) -> T9 p -> T9 q -t9_map f (p,q,r,s,t,u,v,w,x) = (f p,f q,f r,f s,f t,f u,f v,f w,f x) diff --git a/Music/Theory/Unicode.hs b/Music/Theory/Unicode.hs deleted file mode 100644 --- a/Music/Theory/Unicode.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | -module Music.Theory.Unicode where - -type Unicode_Table = [(Int,String)] - --- > putStrLn (map (toEnum . fst) (concat unicode)) -unicode :: [Unicode_Table] -unicode = [accidentals,notes,rests,clefs] - -accidentals :: Unicode_Table -accidentals = - [(0x1D12A,"MUSICAL SYMBOL DOUBLE SHARP") - ,(0x1D12B,"MUSICAL SYMBOL DOUBLE FLAT") - ,(0x1D12C,"MUSICAL SYMBOL FLAT UP") - ,(0x1D12D,"MUSICAL SYMBOL FLAT DOWN") - ,(0x1D12E,"MUSICAL SYMBOL NATURAL UP") - ,(0x1D12F,"MUSICAL SYMBOL NATURAL DOWN") - ,(0x1D130,"MUSICAL SYMBOL SHARP UP") - ,(0x1D131,"MUSICAL SYMBOL SHARP DOWN") - ,(0x1D132,"MUSICAL SYMBOL QUARTER TONE SHARP") - ,(0x1D133,"MUSICAL SYMBOL QUARTER TONE FLAT")] - -notes :: Unicode_Table -notes = - [(0x1D15C,"MUSICAL SYMBOL BREVE") - ,(0x1D15D,"MUSICAL SYMBOL WHOLE NOTE") - ,(0x1D15E,"MUSICAL SYMBOL HALF NOTE") - ,(0x1D15F,"MUSICAL SYMBOL QUARTER NOTE") - ,(0x1D160,"MUSICAL SYMBOL EIGHTH NOTE") - ,(0x1D161,"MUSICAL SYMBOL SIXTEENTH NOTE") - ,(0x1D162,"MUSICAL SYMBOL THIRTY-SECOND NOTE") - ,(0x1D163,"MUSICAL SYMBOL SIXTY-FOURTH NOTE") - ,(0x1D164,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE")] - -rests :: Unicode_Table -rests = - [(0x1D13B,"MUSICAL SYMBOL WHOLE REST") - ,(0x1D13C,"MUSICAL SYMBOL HALF REST") - ,(0x1D13D,"MUSICAL SYMBOL QUARTER REST") - ,(0x1D13E,"MUSICAL SYMBOL EIGHTH REST") - ,(0x1D13F,"MUSICAL SYMBOL SIXTEENTH REST") - ,(0x1D140,"MUSICAL SYMBOL THIRTY-SECOND REST") - ,(0x1D141,"MUSICAL SYMBOL SIXTY-FOURTH REST") - ,(0x1D142,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH REST")] - -clefs :: Unicode_Table -clefs = - [(0x1D11E,"MUSICAL SYMBOL G CLEF") - ,(0x1D11F,"MUSICAL SYMBOL G CLEF OTTAVA ALTA") - ,(0x1D120,"MUSICAL SYMBOL G CLEF OTTAVA BASSA") - ,(0x1D121,"MUSICAL SYMBOL C CLEF") - ,(0x1D122,"MUSICAL SYMBOL F CLEF") - ,(0x1D123,"MUSICAL SYMBOL F CLEF OTTAVA ALTA") - ,(0x1D124,"MUSICAL SYMBOL F CLEF OTTAVA BASSA") - ,(0x1D125,"MUSICAL SYMBOL DRUM CLEF-1") - ,(0x1D126,"MUSICAL SYMBOL DRUM CLEF-2")] diff --git a/Music/Theory/Wyschnegradsky.hs b/Music/Theory/Wyschnegradsky.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Wyschnegradsky.hs @@ -0,0 +1,332 @@ +-- | +module Music.Theory.Wyschnegradsky where + +import Data.Char {- base -} +import Data.List {- list -} +import Data.Maybe {- base -} + +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. +-- +-- > map (normalise_step 6) [-5,-1,1,5] == [1,-1,1,-1] +normalise_step :: (Eq n,Num n) => n -> n -> n +normalise_step m n + | n == 1 = 1 + | n == -1 = -1 + | n == m - 1 = -1 + | n == 1 - m = 1 + | otherwise = error "normalise_step" + +-- | Wyschnegradsky writes the direction sign at the end of the number. +-- +-- > map parse_num_sign ["2+","4-"] == [2,-4] +parse_num_sign :: (Num n, Read n) => String -> n +parse_num_sign s = + case List.separate_last s of + (n,'+') -> read n + (n,'-') -> negate (read n) + _ -> error "parse_num_sign" + +-- | Expand a chromatic (step-wise) sequence, sign indicates direction. +-- +-- > map vec_expand [2,-4] == [[1,1],[-1,-1,-1,-1]] +vec_expand :: Num n => Int -> [n] +vec_expand n = if n > 0 then replicate n 1 else replicate (abs n) (-1) + +-- | Parse the vector notation used in some drawings, a comma +-- separated list of chromatic sequences. +-- +-- > parse_vec Nothing 0 "4-,4+,4-,4+,4-,4+,4-,4+,4-" +-- > parse_vec Nothing 0 "2+,2-,2+,2-,2+,2-,2+,2-,2+,18+" +parse_vec :: Num n => Maybe Int -> n -> String -> [n] +parse_vec n m = + let f = case n of + 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 +add_m n p q = (p + q) `mod` n + +-- | Parse hex colour string, as standard in HTML5. +-- +-- > parse_hex_clr "#e14630" == (225,70,48) +parse_hex_clr :: (Read n,Num n) => String -> (n,n,n) +parse_hex_clr clr = + let f p q = read ("0x" ++ [p,q]) + in case clr of + ['#',p,q,r,s,t,u] -> (f p q,f r s,f t u) + _ -> error "parse_hex" + +-- | Type specialised. +parse_hex_clr_int :: String -> (Int,Int,Int) +parse_hex_clr_int = parse_hex_clr + +-- | Normalise colour by dividing each component by /m/. +-- +-- > clr_normalise 255 (parse_hex_clr "#ff0066") == (1,0,0.4) +clr_normalise :: (Real r,Fractional f) => f -> (r,r,r) -> (f,f,f) +clr_normalise m (r,g,b) = let f x = realToFrac x / m in (f r,f g,f b) + +-- | Sequences are either in 'Radial' or 'Circumferential' order. +data Seq a = Radial [a] | Circumferential [a] + +-- | Group sequence into normal (ie. 'Circumferential') order given +-- drawing dimensions. +seq_group :: Int -> Int -> Seq a -> [[a]] +seq_group c_div r_div s = + case s of + 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.pitch_pp_opt (False,False) . Pitch.octpc_to_pitch Spelling.pc_spell_ks . (,) 4 + in putStrLn . intercalate sep . map (unwords . map f) + +-- * U3 + +-- | Index to colour name abbreviation. +-- +-- > map u3_ix_ch [0..5] == "ROYGBV" +u3_ix_ch :: Integral i => i -> Char +u3_ix_ch = genericIndex "ROYGBV" . (`mod` 6) + +-- | Inverse of 'u3_ix_ch'. +-- +-- > map u3_ch_ix "ROYGBV" == [0..5] +u3_ch_ix :: Char -> Int +u3_ch_ix = fromMaybe (error "u3_ch_ix") . flip elemIndex "ROYGBV" + +-- | Drawing definition, as written by Wyschnegradsky. +-- +-- > mapM_ (\(c,r) -> putStrLn (unlines ["C: " ++ c,"R: " ++ r])) u3_vec_text_iw +u3_vec_text_iw :: [(String, String)] +u3_vec_text_iw = + [("4+,4-,4+,4-,2+" + ,"4-,4+,4-,4+,4-,4+,4-,4+,4-") + ,("9+,2+,2-,2+,2-,2+" + ,"2+,2-,2+,2-,2+,2-,2+,2-,2+,18+") + ,("12-,12+,12-" + ,"18+,18-") + ,("3+,3-,3+,3-,3+,3-" + ,"18+,18-") + ,("9+,9-" + ,"3+,3-,3+,3-,3+,3-,3+,3-,3+,3-,3+,3-") + ,("2+,2-,2+,2-,2+,2-" + ,"6-,6+,6-,6+,6-,6+") + ,("2+,2-,2+,2-,2+,2-" + ,"6+,6-,6+,6-,6+,6-") + ,("6+,6-" + ,"2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-,2+,2-")] + +-- | Re-written for local parser and to correct ambiguities and errors +-- (to align with actual drawing). +-- +-- > 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]) +-- > 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+" + ,"4-,3+,5-,3+,5-,3+,5-,3+,5-") -- 1 + ,("9+,2+,1-,3+,1-,2+" + ,"2+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,2-") -- 2 + ,("12-,12+,12-" + ,"18+,18-") + ,("3+,2-,4+,2-,4+,3-" + ,"18+,18-") + ,("9+,9-" + ,"3+,2-,4+,1-,1+,1-,3+,1-,1+,1-,3+,2-,4+,1-,1+,1-,3+,1-,1+,1-") -- 5 + ,("2+,1-,3+,1-,3+,2-" + ,"6-,6+,6-,6+,6-,6+") -- 6 + ,("2+,1-,3+,1-,3+,2-" + ,"6+,6-,6+,6-,6+,6-") -- 7 + ,("6+,6-" + ,"2+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,1-,3+,2-")] -- 8 + +-- | Parse of 'u3_vec_text_rw'. +-- +-- > let {(c,r) = u3_vec_ix ; c' = map length c} +-- > in (length c,c',sum c',length r,map length r) +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) = List.firstSecond (transpose (map f u3_vec_text_rw)) + in (c,r) + +-- | Radial indices (ie. each /ray/ as an index sequence). +-- +-- > putStrLn $ unlines $ map (map u3_ix_ch) u3_ix_radial +u3_ix_radial :: Integral n => [[n]] +u3_ix_radial = + let (c,r) = u3_vec_ix + r' = zipWith replicate (map length c) r + in zipWith (map . add_m 6) (concat c) (concat r') + +-- | Colour names in index sequence. +u3_clr_nm :: [String] +u3_clr_nm = words "red orange yellow green blue violet" + +-- | Colour values (hex strings) in index sequence. +u3_clr_hex :: [String] +u3_clr_hex = words "#e14630 #e06e30 #e2c48e #498b43 #2a5a64 #cb7b74" + +-- | RGB form of 'u3_clr_hex'. +u3_clr_rgb :: Fractional n => [(n,n,n)] +u3_clr_rgb = map (clr_normalise 256 . parse_hex_clr_int) u3_clr_hex + +-- | Notated radial color sequence, transcribed from drawing. +-- +-- > map (\(n,c) -> let v = u3_ch_seq_to_vec c in (n,sum v,v)) u3_radial_ch +u3_radial_ch :: [(Int,[Char])] +u3_radial_ch = + [(1,"RVBGY GBV BGYOR OYG YORVB VRO RVBGY GBVBGYO") + ,(5,"ROYG YO YGBV BV BVRO RO ROYG YO YGBV BV BVR OR O")] + +-- | Notated circumferenctial color sequence, transcribed from drawing. +-- +-- > map (\(n,c) -> (n,u3_ch_seq_to_vec c)) u3_circ_ch +u3_circ_ch :: [(Int,[Char])] +u3_circ_ch = + [(6,"ROYOYGBGBVRV") + ,(7,"ROYOYGBGBVRV") + ,(8,"ROYGBVRVBGYO")] + +-- | Translate notated sequence to "re-written" vector notation. +u3_ch_seq_to_vec :: [Char] -> [Int] +u3_ch_seq_to_vec = + map length . + group . + map (normalise_step 6) . + List.d_dx . + map u3_ch_ix . + filter (not . isSpace) + +-- * DC9 + +{- | Circumference pitch classes, C = 0. + +> let c' = map length dc9_circ in (sum c',c') == (72,[5,6,7,2,3,4,4,3,2,7,7,4,4,3,2,2,3,4]) + +> iw_pc_pp " | " dc9_circ + +-} +dc9_circ :: Num n => [[n]] +dc9_circ = + [[6,5,4,3,2] + ,[3,2,1,0,11,10] + ,[11,10,9,8,7,6,5] + ,[6,5] + ,[6,5,4] + ,[5,4,3,2] + ,[3,2,1,0] + ,[1,0,11] + ,[0,11] + ,[0,1,2,3,4,5,6] + ,[5,6,7,8,9,10,9] + ,[10,11,0,1] + ,[0,1,2,3] + ,[2,3,4] + ,[3,4] + ,[3,4] + ,[3,4,5] + ,[4,5,6,7]] + +-- | Rayon pitch classes, C = 0. +-- +-- > length dc9_rad == 18 +-- > putStrLn $ unwords $ map f dc9_rad +dc9_rad :: Num n => [n] +dc9_rad = [0,10,8,6,4,2,0,10,8,6,4,2,0,10,8,6,4,2] + +-- | Radial indices. +-- +-- > map length dc9_ix == replicate 72 18 +dc9_ix :: Integral n => [[n]] +dc9_ix = map (\n -> map (add_m 12 n) dc9_rad) (concat dc9_circ) + +-- | Approximate colours, hex strings. +dc9_clr_hex :: [String] +dc9_clr_hex = + let c = ["#e96d61","#e6572b" + ,"#e07122","#e39e36" + ,"#e8b623","#e5c928" + ,"#c2ba3d","#a2a367" + ,"#537a77","#203342" + ,"#84525e","#bc6460"] + 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. +dc9_clr_rgb :: Fractional n => [(n,n,n)] +dc9_clr_rgb = map (clr_normalise 255 . parse_hex_clr_int) dc9_clr_hex + +-- * U11 + +-- > 18 * 4 == 72 +-- > let c' = map length u11_circ in (sum c',length c',c') +-- +-- > iw_pc_pp "\n- " u11_circ +u11_circ :: Num n => [[n]] +u11_circ = + [[7,8,9,10,11,0,1,2,3] + ,[10,11,0,1,2,3,4,5,6] + ,[0,1,2,3,4,5] + ,[0,1,2] + ,[10,11] + ,[6,7] + ,[2] + ,[9] + ,[4] + ,[11] + ,[6,7] + ,[2] + ,[9] + ,[2] + ,[11] + ,[6,7] + ,[2,3] + ,[10,11,0] + ,[7,8,9,10,11,0] + ,[7,8,9,10,11,0,1,2,3] + ,[10,11,0,1,2,3,4,5,6]] + +-- > 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 . 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) + +-- > ull_rad_text == "012588---------885210" +ull_rad_text :: [Char] +ull_rad_text = + let x = "012588----" + y = "-" + in x ++ y ++ reverse x + +-- > iw_pc_pp "\n- " u11_rad +u11_rad :: Integral n => [[n]] +u11_rad = + let f c = if c == '-' then Nothing else Just (read [c]) + in map (u11_seq_rule . f) ull_rad_text + +u11_clr_hex :: [String] +u11_clr_hex = + let c = ["#dbb56a","#ffb05c","#ea7c3f","#f93829","#ee6054","#d18d9c" + ,"#a94c79","#215272","#628b7d","#9dbc90","#ecdfaa","#fbeaa5"] + n = reverse ([4..11] ++ [0..3]) :: [Int] + in map snd (sort (zip n c)) + +u11_clr_rgb :: Fractional n => [(n,n,n)] +u11_clr_rgb = map (clr_normalise 256 . parse_hex_clr_int) u11_clr_hex diff --git a/Music/Theory/Xenakis/S4.hs b/Music/Theory/Xenakis/S4.hs --- a/Music/Theory/Xenakis/S4.hs +++ b/Music/Theory/Xenakis/S4.hs @@ -5,8 +5,8 @@ import Data.List {- base -} import Data.Maybe {- base -} -import qualified Data.Permute as P {- permutation -} +import qualified Music.Theory.List as T import qualified Music.Theory.Permutations as T -- * S4 notation @@ -49,12 +49,12 @@ case sort x of [1,2,3,4] -> x [5,6,7,8] -> complement x - _ -> error "lower" + _ -> error (show ("lower",x)) -- | Application of 'Label' /p/ on /q/. -- -- > l_on Q1 I == Q1 --- > l_on D A == G +-- > l_on D Q12 == Q4 -- > [l_on L L,l_on E D,l_on D E] == [L2,C,B] l_on :: Label -> Label -> Label l_on p q = @@ -63,6 +63,47 @@ r = map (\i -> q' !! (i - 1)) p' in label_of r +{- | Generalisation of Fibonnaci process, /f/ is the binary operator +giving the next element, /p/ and /q/ are the initial elements. + +See discussion in: Carlos Agon, Moreno Andreatta, Gérard Assayag, and +Stéphan Schaub. _Formal Aspects of Iannis Xenakis' "Symbolic Music": A +Computer-Aided Exploration of Compositional Processes_. Journal of New +Music Research, 33(2):145-159, 2004. + +Note that the article has an error, printing Q4 for Q11 in the sequence below. + +> import qualified Music.Theory.List as T + +> let r = [D,Q12,Q4, E,Q8,Q2, E2,Q7,Q4, D2,Q3,Q11, L2,Q7,Q2, L,Q8,Q11] +> (take 18 (fib_proc l_on D Q12) == r,T.duplicates r == [Q2,Q4,Q7,Q8,Q11]) + +Beginning E then G2 no Q nodes are visited. + +> let r = [E,G2,L2,C,G,D,E,B,D2,L,G,C,L2,E2,D2,B] +> (take 16 (fib_proc l_on E G2) == r,T.duplicates r == [B,C,D2,E,G,L2]) + +> let [a,b] = take 2 (T.segments 18 18 (fib_proc l_on D Q12)) in a == b + +The prime numbers that are not factors of 18 are {1,5,7,11,13,17}. +They form a closed group under modulo 18 multiplication. + +> let n = [5,7,11,13,17] +> let r0 = [(5,7,17),(5,11,1),(5,13,11),(5,17,13)] +> let r1 = [(7,11,5),(7,13,1),(7,17,11)] +> let r2 = [(11,13,17),(11,17,7)] +> let r3 = [(13,17,5)] +> [(p,q,(p * q) `mod` 18) | p <- n, q <- n, p < q] == concat [r0,r1,r2,r3] + +The article also omits the 5 after 5,1 in the sequence below. + +> let r = [11,13,17,5,13,11,17,7,11,5,1,5,5,7,17,11,7,5,17,13,5,11,1,11] +> take 24 (fib_proc (\p q -> (p * q) `mod` 18) 11 13) == r + +-} +fib_proc :: (a -> a -> a) -> a -> a -> [a] +fib_proc f p q = let r = f p q in p : fib_proc f q r + -- | 'Seq' of 'Label', inverse of 'label_of'. -- -- > seq_of Q1 == [8,7,5,6,4,3,1,2] @@ -81,15 +122,6 @@ half_seq :: Seq -> Half_Seq half_seq = take 4 --- | Reverse table 'lookup'. --- --- > reverse_lookup 'b' (zip [1..] ['a'..]) == Just 2 --- > lookup 2 (zip [1..] ['a'..]) == Just 'b' -reverse_lookup :: (Eq a) => a -> [(b,a)] -> Maybe b -reverse_lookup i = - let f (p,q) = (q,p) - in lookup i . map f - -- | 'Label' of 'Seq', inverse of 'seq_of'. -- -- > label_of [8,7,5,6,4,3,1,2] == Q1 @@ -97,7 +129,7 @@ label_of :: Seq -> Label label_of i = let err = error ("label_of: " ++ show i) - in fromMaybe err (reverse_lookup i viii_6b) + in fromMaybe err (T.reverse_lookup i viii_6b) -- | 'True' if two 'Half_Seq's are complementary, ie. form a 'Seq'. -- @@ -111,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 @@ -125,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) @@ -135,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 @@ -170,11 +201,10 @@ data Face = F_Back | F_Front | F_Right | F_Left | F_Bottom | F_Top deriving (Eq,Enum,Bounded,Ord,Show) --- | Table indicating set of faces of cubes as drawn in Fig. VIII-6 --- (p.220). +-- | Table indicating set of faces of cubes as drawn in Fig. VIII-6 (p.220). -- -- > lookup [1,4,6,7] faces == Just F_Left --- > reverse_lookup F_Right faces == Just [2,3,5,8] +-- > T.reverse_lookup F_Right faces == Just [2,3,5,8] faces :: [([Int],Face)] faces = [([1,3,6,8],F_Back) -- (I in viii-6) @@ -186,42 +216,56 @@ -- * Figures --- | Fig. VIII-6. Hexahedral (Octahedral) Group (p. 220) +-- | Label sequence of Fig. VIII-6. Hexahedral (Octahedral) Group (p. 220) -- --- > length viii_6_l == 24 --- > take 7 viii_6_l == [L2,L,A,Q1,Q7,Q3,Q9] -viii_6_l :: [Label] -viii_6_l = +-- > let r = [I,A,B,C,D,D2,E,E2,G,G2,L,L2,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,Q10,Q11,Q12] +-- > in viii_6_lseq == r +viii_6_lseq :: [Label] +viii_6_lseq = [L2,L,A,Q1,Q7,Q3,Q9 ,G2,G,C,Q8,Q5,Q10,Q2 ,E,E2,B,Q4,Q11,Q12,Q6 ,D,D2,I] +-- | Label sequence of Fig. VIII-7 (p.221) +-- +-- > let r = [I,A,B,C,D,D2,E,E2,G,G2,L,L2,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,Q10,Q11,Q12] +-- > in viii_7_lseq == r +viii_7_lseq :: [Label] +viii_7_lseq = + [I,A,B,C + ,D,D2,E,E2 + ,G,G2,L,L2 + ,Q1,Q2,Q3,Q4 + ,Q5,Q6,Q7,Q8 + ,Q9,Q10,Q11,Q12] + -- | Fig. VIII-7 (p.221) -- -- > map (take 4) (take 4 viii_7) == [[I,A,B,C] -- > ,[A,I,C,B] -- > ,[B,C,I,A] -- > ,[C,B,A,I]] +-- +-- > import Music.Theory.Array.MD +-- +-- > let t = md_matrix_opt show (\x -> "_" ++ x ++ "_") (head viii_7,head viii_7) viii_7 +-- > putStrLn $ unlines $ md_table' t viii_7 :: [[Label]] -viii_7 = - let o = [I,A,B,C - ,D,D2,E,E2 - ,G,G2,L,L2 - ,Q1,Q2,Q3,Q4 - ,Q5,Q6,Q7,Q8 - ,Q9,Q10,Q11,Q12] - in map (\i -> map (`l_on` i) o) o +viii_7 = map (\i -> map (`l_on` i) viii_7_lseq) viii_7_lseq --- | Fig. VIII-6/b 'Labels' (p.221) +-- | Label sequence of Fig. VIII-6/b (p.221) -- -- > length viii_6b_l == length viii_6_l -- > take 8 viii_6b_l == [I,A,B,C,D2,D,E2,E] -viii_6b_l :: [Label] -viii_6b_l = - [I,A,B,C,D2,D,E2,E - ,G2,G,L2,L,Q7,Q2,Q3,Q11 - ,Q8,Q6,Q1,Q5,Q9,Q10,Q4,Q12] +viii_6b_lseq :: [Label] +viii_6b_lseq = + [I,A,B,C + ,D2,D,E2,E + ,G2,G,L2,L + ,Q7,Q2,Q3,Q11 + ,Q8,Q6,Q1,Q5 + ,Q9,Q10,Q4,Q12] -- | Fig. VIII-6/b 'Half_Seq'. -- @@ -258,7 +302,7 @@ -- | Variant of 'viii_6b' with 'Half_Seq'. viii_6b' :: [(Label,Half_Seq)] -viii_6b' = zip viii_6b_l viii_6b_p' +viii_6b' = zip viii_6b_lseq viii_6b_p' -- | Fig. VIII-6/b. -- @@ -266,19 +310,19 @@ -- > ,(G2,[3,2,4,1,7,6,8,5]) -- > ,(Q8,[6,8,5,7,2,4,1,3])] viii_6b :: [(Label,Seq)] -viii_6b = zip viii_6b_l (map full_seq viii_6b_p') +viii_6b = zip viii_6b_lseq (map full_seq viii_6b_p') -- | The sequence of 'Rel' to give 'viii_6_l' from 'L2'. -- -- > apply_relations_l viii_6_relations L2 == viii_6_l -- > length (nub viii_6_relations) == 14 viii_6_relations :: [Rel] -viii_6_relations = relations (map half_seq_of viii_6_l) +viii_6_relations = relations (map half_seq_of viii_6_lseq) -- | The sequence of 'Rel' to give 'viii_6b_l' from 'I'. -- -- > apply_relations_l viii_6b_relations I == viii_6b_l -- > length (nub viii_6b_relations) == 10 viii_6b_relations :: [Rel] -viii_6b_relations = relations (map half_seq_of viii_6b_l) +viii_6b_relations = relations (map half_seq_of viii_6b_lseq) diff --git a/Music/Theory/Xenakis/Sieve.hs b/Music/Theory/Xenakis/Sieve.hs --- a/Music/Theory/Xenakis/Sieve.hs +++ b/Music/Theory/Xenakis/Sieve.hs @@ -6,14 +6,12 @@ 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' deriving (Eq,Show) -- | The 'Union' of a list of 'Sieve's, ie. 'foldl1' 'Union'. @@ -32,23 +30,39 @@ (∩) :: Sieve -> Sieve -> Sieve (∩) = Intersection +-- | Synonym for 'Complement'. +c :: Sieve -> Sieve +c = Complement + +-- | Pretty-print sieve. Fully parenthesised. +sieve_pp :: Sieve -> String +sieve_pp s = + case s of + Empty -> "∅" + L (p,q) -> concat [show p,".",show q] + Union p q -> concat ["(",sieve_pp p," ∪ ",sieve_pp q,")"] + Intersection p q -> concat ["(",sieve_pp p," ∩ ",sieve_pp q,")"] + Complement p -> concat ["(∁ ",sieve_pp p,")"] + -- | 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) +{- | 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 @@ -56,33 +70,53 @@ L (m,i) -> L (m,i `mod` m) Union s0 s1 -> Union (normalise s0) (normalise s1) 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 +{- | 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 L (m,i) -> n `mod` m == i `mod` m && n >= i Union s0 s1 -> element s0 n || element s1 n Intersection s0 s1 -> element s0 n && element s1 n + Complement s' -> not (element s' n) --- | 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] +{- | '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 ..] + e:s' -> case compare x e of + LT -> x : f (x + 1) s + EQ -> f (x + 1) s' + 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] +> 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] @@ -93,9 +127,9 @@ L (m,i) -> [i, i+m ..] Union s0 s1 -> u_f (merge (build s0) (build s1)) Intersection s0 s1 -> i_f (merge (build s0) (build s1)) + 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] @@ -106,46 +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) +> 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 {- hmt -} + +> 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] +> 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] +> 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) +> 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) +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 @@ -153,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 @@ -173,18 +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) --- --- > 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 = @@ -202,3 +298,44 @@ Intersection s1 Empty -> s1 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 diff --git a/Music/Theory/Z.hs b/Music/Theory/Z.hs --- a/Music/Theory/Z.hs +++ b/Music/Theory/Z.hs @@ -1,94 +1,146 @@ --- | Generalised Z-/n/ functions. +-- | Z-/n/ functions module Music.Theory.Z where -{- - -From GHC 7.6 onwards there is the modular-arithmetic package, which subsumes this work. - -{-# Language DataKinds #-} - -import Data.Modular {- modular-arithmetic -} -import GHC.TypeLits {- base -} +import Data.Char {- base -} +import Data.List {- base -} -type Z n = Mod Integer n +import qualified Music.Theory.List as T {- hmt -} --- > map negate [0::Z12 .. 11] == [0,11,10,9,8,7,6,5,4,3,2,1] --- > map (+ 5) [0::Z12 .. 11] == [5,6,7,8,9,10,11,0,1,2,3,4] -type Z12 = Mod Integer 12 +-- | Z type. +-- +-- > map z_modulus [z7,z12] == [7,12] +newtype Z i = Z {z_modulus :: i} --- > map invert [0::Z12 .. 11] == [0,11,10,9,8,7,6,5,4,3,2,1] -invert :: KnownNat n => Z n -> Z n -invert = negate +-- | 'mod' of 'Z'. +-- +-- > map (z_mod z12) [-1,0,1,11,12,13] == [11,0,1,11,0,1] +z_mod :: Integral i => Z i -> i -> i +z_mod (Z i) n = mod n i --} +-- | Common moduli in music theory. +z5,z7,z12,z16 :: Num i => Z i +z5 = Z 5 +z7 = Z 7 +z12 = Z 12 +z16 = Z 16 -import Data.List {- base -} +-- | Is /n/ in (0,/m/-1). +is_z_n :: (Num a, Ord a) => a -> a -> Bool +is_z_n m n = n >= 0 && n < m -lift_unary_Z :: Integral a => a -> (t -> a) -> t -> a -lift_unary_Z z f n = mod (f n) z +lift_unary_Z :: Integral i => Z i -> (t -> i) -> t -> i +lift_unary_Z z f = z_mod z . f -lift_binary_Z :: Integral a => a -> (s -> t -> a) -> s -> t -> a -lift_binary_Z z f n1 n2 = mod (n1 `f` n2) z +lift_binary_Z :: Integral i => Z i -> (s -> t -> i) -> s -> t -> i +lift_binary_Z z f n1 = z_mod z . f n1 --- > import Music.Theory.Z --- > import qualified Music.Theory.Z12 as Z12 --- > z_mod 12 (6::Z12.Z12) 12 --- > z_add 12 (1::Z12.Z12) 5 --- > (1::Z12.Z12) + 5 --- > map (z_add 12 4) [1,5,6] == [5,9,10] -z_add :: Integral a => a -> a -> a -> a +-- | Add two Z. +-- +-- > map (z_add z12 4) [1,5,6,11] == [5,9,10,3] +z_add :: Integral i => Z i -> i -> i -> i z_add z = lift_binary_Z z (+) -z_sub :: Integral a => a -> a -> a -> a +-- | The underlying type /i/ is presumed to be signed... +-- +-- > z_sub z12 0 8 == 4 +-- +-- > import Data.Word {- base -} +-- > z_sub z12 (0::Word8) 8 == 8 +-- > ((0 - 8) :: Word8) == 248 +-- > 248 `mod` 12 == 8 +z_sub :: Integral i => Z i -> i -> i -> i z_sub z = lift_binary_Z z (-) -z_mul :: Integral a => a -> a -> a -> a +-- | Allowing unsigned /i/ is rather inefficient... +-- +-- > z_sub_unsigned z12 (0::Word8) 8 == 4 +z_sub_unsigned :: (Integral i,Ord i) => Z i -> i -> i -> i +z_sub_unsigned z p q = + if p > q + then z_mod z (p - q) + else z_mod z (p + z_modulus z - q) + +z_mul :: Integral i => Z i -> i -> i -> i z_mul z = lift_binary_Z z (*) -z_negate :: Integral a => a -> a -> a -z_negate z = lift_unary_Z z negate +-- > z_negate z12 7 == 5 +z_negate :: Integral i => Z i -> i -> i +z_negate z = z_sub z 0 -- error "Z numbers are not signed" -z_fromInteger :: Integral a => a -> Integer -> a -z_fromInteger z i = fromInteger i `mod` z +z_fromInteger :: Integral i => Z i -> Integer -> i +z_fromInteger z i = z_mod z (fromInteger i) -z_signum :: t -> t1 -> t2 +z_signum :: t -> u -> v z_signum _ _ = error "Z numbers are not signed" -z_abs :: t -> t1 -> t2 +z_abs :: t -> u -> v z_abs _ _ = error "Z numbers are not signed" --- > map (to_Z 12) [-9,-3,0] == [3,9,0] -to_Z :: Integral i => i -> i -> i +-- > map (to_Z z12) [-9,-3,0] == [3,9,0] +to_Z :: Integral i => Z i -> i -> i to_Z z = z_fromInteger z . fromIntegral from_Z :: (Integral i,Num n) => i -> n from_Z = fromIntegral --- | Z not in set. +-- | Universe of 'Z'. -- --- > z_complement 5 [0,2,3] == [1,4] --- > z_complement 12 [0,2,4,5,7,9,11] == [1,3,6,8,10] -z_complement :: (Enum a, Eq a, Num a) => a -> [a] -> [a] -z_complement z = (\\) [0 .. z - 1] +-- > z_univ z12 == [0..11] +z_univ :: Integral i => Z i -> [i] +z_univ (Z z) = [0 .. z - 1] -z_quot :: Integral i => i -> i -> i -> i +-- | Z of 'z_univ' not in given set. +-- +-- > z_complement z5 [0,2,3] == [1,4] +-- > z_complement z12 [0,2,4,5,7,9,11] == [1,3,6,8,10] +z_complement :: Integral i => Z i -> [i] -> [i] +z_complement z = (\\) (z_univ z) + +z_quot :: Integral i => Z i -> i -> i -> i z_quot z p = to_Z z . quot p -z_rem :: Integral c => c -> c -> c -> c +z_rem :: Integral i => Z i -> i -> i -> i z_rem z p = to_Z z . rem p -z_div :: Integral c => c -> c -> c -> c -z_div z p = to_Z z . div p +div_err :: Integral i => String -> i -> i -> i +div_err s p q = if q == 0 then error ("div_err: zero" ++ s) else p `div` q --- > z_mod 12 6 12 -z_mod :: Integral c => c -> c -> c -> c -z_mod z p = to_Z z . mod p +z_div :: Integral i => Z i -> i -> i -> i +z_div z p = to_Z z . div_err "z_div" p -z_quotRem :: Integral t => t -> t -> t -> (t, t) +z_quotRem :: Integral i => Z i -> i -> i -> (i,i) z_quotRem z p q = (z_quot z p q,z_quot z p q) -z_divMod :: Integral t => t -> t -> t -> (t, t) -z_divMod z p q = (z_div z p q,z_mod z p q) +z_divMod :: Integral i => Z i -> i -> i -> (i,i) +z_divMod z p q = (z_div z p q,z_mod z (mod p q)) -z_toInteger :: Integral i => i -> i -> i -z_toInteger z = to_Z z +z_toInteger :: Integral i => Z i -> i -> i +z_toInteger = to_Z + +-- * Z16 + +-- | Type generalised 'intToDigit'. +-- +-- > map integral_to_digit [0 .. 15] == "0123456789abcdef" +integral_to_digit :: Integral t => t -> Char +integral_to_digit = intToDigit . fromIntegral + +-- | 'is_z_n' 16. +is_z16 :: Integral t => t -> Bool +is_z16 = is_z_n 16 + +-- | Alias for 'integral_to_digit'. +z16_to_char :: Integral t => t -> Char +z16_to_char = integral_to_digit + +-- | 'z16_to_char' in braces, {1,2,3}. +z16_set_pp :: Integral t => [t] -> String +z16_set_pp = T.bracket ('{','}') . map z16_to_char + +-- | 'z16_to_char' in arrows, <1,2,3>. +z16_seq_pp :: Integral t => [t] -> String +z16_seq_pp = T.bracket ('<','>') . map z16_to_char + +-- | 'z16_to_char' in brackets, [1,2,3]. +z16_vec_pp :: Integral t => [t] -> String +z16_vec_pp = T.bracket ('[',']') . map z16_to_char diff --git a/Music/Theory/Z/Boros_1990.hs b/Music/Theory/Z/Boros_1990.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Boros_1990.hs @@ -0,0 +1,300 @@ +-- | James Boros. "Some Properties of the All-Trichord Hexachord". +-- _In Theory Only_, 11(6):19--41, 1990. +module Music.Theory.Z.Boros_1990 where + +import Data.Char {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Numeric {- base -} + +import qualified Data.Graph.Inductive.Graph as G {- fgl -} +import qualified Data.Graph.Inductive.Basic as G {- fgl -} +import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -} +import qualified Data.Graph.Inductive.Query.BFS as G {- fgl -} + +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.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 + +-- * Util + +singular :: String -> [t] -> t +singular err l = + case l of + [x] -> x + _ -> error ("not singular: " ++ err) + +set_eq :: Ord t => [t] -> [t] -> Bool +set_eq p q = T.set p == T.set q + +elem_by :: (t -> t -> Bool) -> t -> [t] -> Bool +elem_by f e = any (f e) + +-- * Tto + +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]] +all_tn p = map (\n -> map (T.z_add T.z12 n) p) [0..11] + +all_tni :: Integral i => [i] -> [[i]] +all_tni p = map (\f -> T.z_tto_apply T.z12 f p) tto_tni_univ + +uniq_tni :: Integral i => [i] -> [[i]] +uniq_tni = nub . all_tni + +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 = T.z_tto_tn T.z12 + +-- | Forte prime forms of the twelve trichordal set classes. +-- +-- > length trichords == 12 +trichords :: [Pcset] +trichords = filter ((== 3) . length) (T.z_sc_univ T.z12) + +-- | Is a pcset self-inversional, ie. is the inversion of /p/ a transposition of /p/. +-- +-- > map (\p -> (p,self_inv p)) trichords +self_inv :: Pcset -> Bool +self_inv p = elem_by set_eq (map (T.z_negate T.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 = 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 . concatMap (`showHex` "") + +-- * Ath + +-- | Forte prime form of the all-trichord hexachord. +-- +-- > T.sc_name ath == "6-Z17" +-- > T.sc "6-Z17" == ath +ath :: Pcset +ath = [0,1,2,4,7,8] + +-- | Is /p/ an instance of 'ath'. +is_ath :: Pcset -> Bool +is_ath p = T.z_forte_prime T.z12 p == ath + +-- | Table 1, p.20 +-- +-- > length ath_univ == 24 +ath_univ :: [Pcset] +ath_univ = uniq_tni 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 = 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 p = + let r = ath_tni p + h = if T.tto_I r then 'h' else 'H' + in h : show (T.tto_T r) + +-- | The twenty three-element subsets of 'ath'. +-- +-- > length ath_trichords == 20 +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 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 p q = + let f z = is_ath (p ++ z) + in filter f (uniq_tni q) + +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 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 n = let f (p,q) = (pcset_trs n p,pcset_trs n q) in map f + +-- * Tables + +-- > length table_3 == 20 +table_3 :: [((Pcset,Sc,T.SC_Name),(Pcset,Sc,T.SC_Name))] +table_3 = + let f p = let q = ath_complement p + i x = (x,T.z_forte_prime T.z12 x,T.sc_name x) + in (i p,i q) + in map f ath_trichords + +pp_tbl :: T.Text_Table -> [String] +pp_tbl = T.table_pp T.table_opt_simple + +-- > putStrLn $ unlines $ table_3_md +table_3_md :: [String] +table_3_md = + let pp = pcset_pp_hex + f ((p,q,r),(s,t,u)) = [pp p,pp q,r,pp s,pp t,u] + hdr = ["P","P/SC","P/F","Q=H0-P","Q/SC","Q/F"] + in 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 = nub (map T.t2_sort table_3) + +-- > putStrLn $ unlines $ table_4_md +table_4_md :: [String] +table_4_md = + let pp = pcset_pp_hex + f ((p,q,r),(s,t,u)) = [pp p ++ "/" ++ pp s,pp q ++ "/" ++ pp t,r ++ "/" ++ u] + hdr = ["Trichords","Prime Forms","Forte Numbers"] + in pp_tbl (hdr : map f table_4) + +table_5 :: [(Pcset,Int)] +table_5 = T.histogram (map (T.z_forte_prime T.z12) ath_trichords) + +-- > putStrLn $ unlines $ table_5_md +table_5_md :: [String] +table_5_md = + let f (p,q) = [pcset_pp_hex p,show q] + in pp_tbl (["SC","#ATH"] : map f table_5) + +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 + +-- > putStrLn $ unlines $ table_6_md +table_6_md :: [String] +table_6_md = + let f (p,q,r) = [pcset_pp_hex p,show q,show r] + in pp_tbl (["SC","#H0","#Hn"] : map f table_6) + +-- * Figures + +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 = T.g_from_edges fig_1 + +-- > putStrLn $ unlines $ map (unwords . map pcset_pp) fig_2 +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 (\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 = map (concatMap (T.adj2 1) . realise_ath_seq) fig_2 + +fig_3_gr :: [G.Gr Pcset ()] +fig_3_gr = map T.g_from_edges fig_3 + +fig_4 :: [[T.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 = + let c = [0,4,8] + f gr = case ath_gr_extend gr c of + [] -> Nothing + r -> Just (gr ++ r) + g0 = concat fig_4 + in mapMaybe (\n -> f (gr_trs n g0)) [0 .. 11] + +-- * Drawing + +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 v = ("shape",if self_inv v then "doublecircle" else "circle") + +type Gr = G.Gr Pcset () + +gr_pp' :: (Pcset -> String) -> T.Graph_Pp Pcset () +gr_pp' f = (\(_,v) -> [set_shape v,("label",f v)],const []) + +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 = T.g_from_edges (uedge_set (concat fig_3)) + +d_fig_3 :: [String] +d_fig_3 = T.fgl_to_udot [] gr_pp d_fig_3_g + +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 = 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 = 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_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' = T.g_from_edges_l d_fig_5_e + +d_fig_5' :: [String] +d_fig_5' = + 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' diff --git a/Music/Theory/Z/Castren_1994.hs b/Music/Theory/Z/Castren_1994.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Castren_1994.hs @@ -0,0 +1,153 @@ +-- | Marcus Castrén. +-- /RECREL: A Similarity Measure for Set-Classes/. +-- PhD thesis, Sibelius Academy, Helsinki, 1994. +module Music.Theory.Z.Castren_1994 where + +import Data.Int {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} +import Data.Ratio {- base -} + +import qualified Music.Theory.List as List +import Music.Theory.Z +import qualified Music.Theory.Z.Forte_1973 as Forte +import qualified Music.Theory.Z.Sro as Sro + +type Z12 = Int8 + +-- | Is /p/ symmetrical under inversion. +-- +-- > map inv_sym (Forte.scs_n 2) == [True,True,True,True,True,True] +-- > map (fromEnum.inv_sym) (Forte.scs_n 3) == [1,0,0,0,0,1,0,0,1,1,0,1] +inv_sym :: [Z12] -> Bool +inv_sym x = x `elem` map (\i -> sort (Sro.z_sro_tn z12 i (Sro.z_sro_invert z12 0 x))) [0..11] + +-- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'. +-- +-- > sc_t_ti [0,2,4] == Nothing +-- > sc_t_ti [0,1,3] == Just ([0,1,3],[0,2,3]) +sc_t_ti :: [Z12] -> Maybe ([Z12], [Z12]) +sc_t_ti p = + if inv_sym p + then Nothing + else Just (p,Forte.z_t_prime z12 (Sro.z_sro_invert z12 0 p)) + +-- | Transpositional equivalence variant of Forte's 'sc_table'. The +-- inversionally related classes are distinguished by labels @A@ and +-- @B@; the class providing the /best normal order/ (Forte 1973) is +-- always the @A@ class. If neither @A@ nor @B@ appears in the name of +-- a set-class, it is inversionally symmetrical. +-- +-- > (length Forte.sc_table,length t_sc_table) == (224,352) +-- > lookup "5-Z18B" t_sc_table == Just [0,2,3,6,7] +t_sc_table :: [(Forte.SC_Name,[Z12])] +t_sc_table = + let f x = let nm = Forte.sc_name x + in case sc_t_ti x of + Nothing -> [(nm,x)] + Just (p,q) -> [(nm++"A",p),(nm++"B",q)] + in concatMap f Forte.scs + +-- | Lookup a set-class name. The input set is subject to +-- 't_prime' before lookup. +-- +-- > t_sc_name [0,2,3,6,7] == "5-Z18B" +-- > t_sc_name [0,1,4,6,7,8] == "6-Z17B" +t_sc_name :: [Z12] -> Forte.SC_Name +t_sc_name p = + let n = find (\(_,q) -> Forte.z_t_prime z12 p == q) t_sc_table + in fst (fromJust n) + +-- | Lookup a set-class given a set-class name. +-- +-- > t_sc "6-Z17A" == [0,1,2,4,7,8] +t_sc :: Forte.SC_Name -> [Z12] +t_sc n = snd (fromJust (find (\(m,_) -> n == m) t_sc_table)) + +-- | List of set classes. +t_scs :: [[Z12]] +t_scs = map snd t_sc_table + +-- | Cardinality /n/ subset of 't_scs'. +-- +-- > map (length . t_scs_n) [2..10] == [6,19,43,66,80,66,43,19,6] +t_scs_n :: Integral i => i -> [[Z12]] +t_scs_n n = filter ((== n) . genericLength) t_scs + +-- | T-related /q/ that are subsets of /p/. +-- +-- > t_subsets [0,1,2,3,4] [0,1] == [[0,1],[1,2],[2,3],[3,4]] +-- > t_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4]] +-- > t_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6]] +t_subsets :: [Z12] -> [Z12] -> [[Z12]] +t_subsets x a = filter (`List.is_subset` x) (map sort (Sro.z_sro_t_related z12 a)) + +-- | T\/I-related /q/ that are subsets of /p/. +-- +-- > ti_subsets [0,1,2,3,4] [0,1] == [[0,1],[1,2],[2,3],[3,4]] +-- > ti_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4],[0,3,4]] +-- > ti_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6],[3,6,7]] +ti_subsets :: [Z12] -> [Z12] -> [[Z12]] +ti_subsets x a = filter (`List.is_subset` x) (nub (map sort (Sro.z_sro_ti_related z12 a))) + +-- | Trivial run length encoder. +-- +-- > rle "abbcccdde" == [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')] +rle :: (Eq a,Integral i) => [a] -> [(i,a)] +rle = + let f x = (genericLength x,head x) + in map f . group + +-- | Inverse of 'rle'. +-- +-- > rle_decode [(5,'a'),(4,'b')] == "aaaaabbbb" +rle_decode :: (Integral i) => [(i,a)] -> [a] +rle_decode = + let f (i,j) = genericReplicate i j + in concatMap f + +-- | Length of /rle/ encoded sequence. +-- +-- > rle_length [(5,'a'),(4,'b')] == 9 +rle_length :: (Integral i) => [(i,a)] -> i +rle_length = sum . map fst + +-- | T-equivalence /n/-class vector (subset-class vector, nCV). +-- +-- > t_n_class_vector 2 [0..4] == [4,3,2,1,0,0] +-- > rle (t_n_class_vector 3 [0..4]) == [(1,3),(2,2),(2,1),(4,0),(1,1),(9,0)] +-- > rle (t_n_class_vector 4 [0..4]) == [(1,2),(3,1),(39,0)] +t_n_class_vector :: (Num a, Integral i) => i -> [Z12] -> [a] +t_n_class_vector n x = + let a = t_scs_n n + in map (genericLength . t_subsets x) a + +-- | T\/I-equivalence /n/-class vector (subset-class vector, nCV). +-- +-- > ti_n_class_vector 2 [0..4] == [4,3,2,1,0,0] +-- > ti_n_class_vector 3 [0,1,2,3,4] == [3,4,2,0,0,1,0,0,0,0,0,0] +-- > rle (ti_n_class_vector 4 [0,1,2,3,4]) == [(2,2),(1,1),(26,0)] +ti_n_class_vector :: (Num b, Integral i) => i -> [Z12] -> [b] +ti_n_class_vector n x = + let a = Forte.scs_n n + in map (genericLength . ti_subsets x) a + +-- | 'icv' scaled by sum of /icv/. +-- +-- > dyad_class_percentage_vector [0,1,2,3,4] == [40,30,20,10,0,0] +-- > dyad_class_percentage_vector [0,1,4,5,7] == [20,10,20,20,20,10] +dyad_class_percentage_vector :: Integral i => [Z12] -> [i] +dyad_class_percentage_vector p = + let p' = Forte.z_icv z12 p + in map (sum p' *) p' + +-- | /rel/ metric. +-- +-- > rel [0,1,2,3,4] [0,1,4,5,7] == 40 +-- > rel [0,1,2,3,4] [0,2,4,6,8] == 60 +-- > rel [0,1,4,5,7] [0,2,4,6,8] == 60 +rel :: Integral i => [Z12] -> [Z12] -> Ratio i +rel x y = + let x' = dyad_class_percentage_vector x + y' = dyad_class_percentage_vector y + in sum (map abs (zipWith (-) x' y')) % 2 diff --git a/Music/Theory/Z/Clough_1979.hs b/Music/Theory/Z/Clough_1979.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Clough_1979.hs @@ -0,0 +1,127 @@ +-- | John Clough. "Aspects of Diatonic Sets". +-- _Journal of Music Theory_, 23(1):45--61, 1979. +module Music.Theory.Z.Clough_1979 where + +import Data.List {- base -} + +import qualified Music.Theory.List as T {- hmt -} + +-- | Shift sequence so the initial value is zero. +-- +-- > transpose_to_zero [1,2,5] == [0,1,4] +transpose_to_zero :: Num n => [n] -> [n] +transpose_to_zero p = + case p of + [] -> [] + n:_ -> map (subtract n) p + +-- | Diatonic pitch class (Z7) set to /chord/. +-- +-- > map dpcset_to_chord [[0,1],[0,2,4],[2,3,4,5,6]] == [[1,6],[2,2,3],[1,1,1,1,3]] +dpcset_to_chord :: Integral n => [n] -> [n] +dpcset_to_chord = T.d_dx . (++ [7]) . transpose_to_zero . nub . sort + +-- | Inverse of 'dpcset_to_chord'. +-- +-- > map chord_to_dpcset [[1,6],[2,2,3]] == [[0,1],[0,2,4]] +chord_to_dpcset :: Integral n => [n] -> [n] +chord_to_dpcset = T.dropRight 1 . T.dx_d 0 + +-- | Complement, ie. in relation to 'z7_univ'. +-- +-- > map dpcset_complement [[0,1],[0,2,4]] == [[2,3,4,5,6],[1,3,5,6]] +dpcset_complement :: Integral n => [n] -> [n] +dpcset_complement p = filter (`notElem` p) z7_univ + +-- | Interval class predicate (ie. 'is_z4'). +-- +-- > map is_ic [-1 .. 4] == [False,True,True,True,True,False] +is_ic :: Integral n => n -> Bool +is_ic = is_z4 + +-- | Interval to interval class. +-- +-- > map i_to_ic [0..7] == [0,1,2,3,3,2,1,0] +i_to_ic :: Integral n => n -> n +i_to_ic n = if n > 3 then 7 - n else n + +-- | Is /chord/, ie. is 'sum' @7@. +-- +-- > is_chord [2,2,3] +is_chord :: Integral n => [n] -> Bool +is_chord = (== 7) . sum + +-- | Interval vector, given list of intervals. +-- +-- > iv [2,2,3] == [0,2,1] +iv :: Integral n => [n] -> [n] +iv p = + let h = T.generic_histogram p + f n = T.lookup_def n 0 h + in map f [1,2,3] + +-- | Comparison function for 'inv'. +inf_cmp :: Ord a => [a] -> [a] -> Ordering +inf_cmp p q = + if null p && null q + then EQ + else case compare (last p) (last q) of + EQ -> inf_cmp (T.dropRight 1 p) (T.dropRight 1 q) + r -> r + +-- | Interval normal form. +-- +-- > map inf [[2,2,3],[1,2,4],[2,1,4]] == [[2,2,3],[1,2,4],[2,1,4]] +inf :: Integral n => [n] -> [n] +inf = maximumBy inf_cmp . T.rotations + +-- | Inverse of chord (retrograde). +-- +-- > let p = [1,2,4] in (inf p,invert p,inf (invert p)) == ([1,2,4],[4,2,1],[2,1,4]) +invert :: [n] -> [n] +invert = reverse + +-- | Complement of /chord/. +-- +-- > let r = [[1,1,1,1,3],[1,1,1,2,2],[1,1,2,1,2],[1,1,1,4],[2,1,1,3],[1,2,1,3],[1,2,2,2]] +-- > in map complement [[1,6],[2,5],[3,4],[1,1,5],[1,2,4],[1,3,3],[2,2,3]] == r +complement :: Integral n => [n] -> [n] +complement = inf . dpcset_to_chord . dpcset_complement . chord_to_dpcset + +-- | Z7 pitch sequence to Z7 interval sequence, ie. 'mod7' of 'T.d_dx'. +-- +-- > map iseq (permutations [0,1,2]) == [[1,1],[6,2],[6,6],[1,5],[5,1],[2,6]] +-- > map iseq (permutations [0,1,3]) == [[1,2],[6,3],[5,6],[2,4],[4,1],[3,5]] +-- > map iseq (permutations [0,2,3]) == [[2,1],[5,3],[6,5],[1,4],[4,2],[3,6]] +-- > map iseq (permutations [0,1,4]) == [[1,3],[6,4],[4,6],[3,3],[3,1],[4,4]] +-- > map iseq (permutations [0,2,4]) == [[2,2],[5,4],[5,5],[2,3],[3,2],[4,5]] +iseq :: Integral n => [n] -> [n] +iseq = map mod7 . T.d_dx + +-- * Z + +-- | Is /n/ in (0,/m/ - 1). +is_z_n :: Integral n => n -> n -> Bool +is_z_n m n = n >= 0 && n < m + +-- | Z /m/ universe, ie [0 .. m-1]. +z_n_univ :: Integral n => n -> [n] +z_n_univ m = [0 .. m - 1] + +-- | 'is_z_n' of 4. +is_z4 :: Integral n => n -> Bool +is_z4 = is_z_n 4 + +-- | 'z_n_univ' of 7. +-- +-- > z7_univ == [0 .. 6] +z7_univ :: Integral n => [n] +z7_univ = z_n_univ 7 + +-- | 'is_z_n' of 7. +is_z7 :: Integral n => n -> Bool +is_z7 = is_z_n 7 + +-- | 'mod' 7. +mod7 :: Integral n => n -> n +mod7 n = n `mod` 7 diff --git a/Music/Theory/Z/Drape_1999.hs b/Music/Theory/Z/Drape_1999.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Drape_1999.hs @@ -0,0 +1,578 @@ +-- | Haskell implementations of @pct@ operations. +-- See +module Music.Theory.Z.Drape_1999 where + +import Data.Function {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Set.List as T {- hmt -} +import qualified Music.Theory.Tuple as T {- hmt -} +import Music.Theory.Z +import Music.Theory.Z.Forte_1973 +import Music.Theory.Z.Sro +import Music.Theory.Z.Tto + +-- | Cardinality filter +-- +-- > cf [0,3] (cg [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]] +cf :: (Integral n) => [n] -> [[a]] -> [[a]] +cf ns = filter (\p -> genericLength p `elem` ns) + +-- | Combinatorial sets formed by considering each set as possible +-- values for slot. +-- +-- > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]] +-- > let n = "01" in cgg [n,n,n] == ["000","001","010","011","100","101","110","111"] +cgg :: [[a]] -> [[a]] +cgg l = + case l of + x:xs -> [ y:z | y <- x, z <- cgg xs ] + _ -> [[]] + +-- | Combinations generator, ie. synonym for 'powerset'. +-- +-- > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]] +cg :: [a] -> [[a]] +cg = T.powerset + +-- | Powerset filtered by cardinality. +-- +-- >>> pct cg -r3 0159 +-- 015 +-- 019 +-- 059 +-- 159 +-- +-- > cg_r 3 [0,1,5,9] == [[0,1,5],[0,1,9],[0,5,9],[1,5,9]] +cg_r :: (Integral n) => n -> [a] -> [[a]] +cg_r n = cf [n] . cg + +{- | Chain pcsegs. + +>>> echo 024579 | pct chn T0 3 | sort -u +579468 (RT8M) +579A02 (T5) + +> chn_t0 z12 3 [0,2,4,5,7,9] == [[5,7,9,10,0,2],[5,7,9,4,6,8]] + +>>> echo 02457t | pct chn T0 2 +7A0135 (RT5I) +7A81B9 (RT9MI) + +> chn_t0 z12 2 [0,2,4,5,7,10] == [[7,10,0,1,3,5],[7,10,8,1,11,9]] + +-} +chn_t0 :: Integral i => Z i -> Int -> [i] -> [[i]] +chn_t0 z n p = + let f q = T.take_right n p == take n q + in filter f (z_sro_rtmi_related z p) + +{- | Cyclic interval segment. + +>>> echo 014295e38t76 | pct cisg +13A7864529B6 + +> ciseg z12 [0,1,4,2,9,5,11,3,8,10,7,6] == [1,3,10,7,8,6,4,5,2,9,11,6] + +-} +ciseg :: Integral i => Z i -> [i] -> [i] +ciseg z = T.d_dx_by (z_sub z) . cyc + +-- | Synonynm for 'z_complement'. +-- +-- >>> pct cmpl 02468t +-- 13579B +-- +-- > cmpl z12 [0,2,4,6,8,10] == [1,3,5,7,9,11] +cmpl :: Integral i => Z i -> [i] -> [i] +cmpl = z_complement + +-- | Form cycle. +-- +-- >>> echo 056 | pct cyc +-- 0560 +-- +-- > cyc [0,5,6] == [0,5,6,0] +cyc :: [a] -> [a] +cyc l = + case l of + [] -> [] + x:xs -> (x:xs) ++ [x] + +-- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor +-- set, 'o' for octotonic set. +d_nm :: (Integral a) => [a] -> Maybe Char +d_nm x = + case x of + [0,2,4,5,7,9,11] -> Just 'd' + [0,2,3,5,7,9,11] -> Just 'm' + [0,1,3,4,6,7,9,10] -> Just 'o' + _ -> Nothing + +-- | Diatonic implications. +dim :: Integral i => [i] -> [(i,[i])] +dim p = + let g (i,q) = T.is_subset p (z_tto_tn z12 i q) + f = filter g . zip [0..11] . repeat + d = [0,2,4,5,7,9,11] + m = [0,2,3,5,7,9,11] + o = [0,1,3,4,6,7,9,10] + in f d ++ f m ++ f o + +-- | Variant of 'dim' that is closer to the 'pct' form. +-- +-- >>> pct dim 016 +-- T1d +-- T1m +-- T0o +-- +-- > dim_nm [0,1,6] == [(1,'d'),(1,'m'),(0,'o')] +dim_nm :: Integral i => [i] -> [(i,Char)] +dim_nm = + let pk f (i,j) = (i,f j) + in nubBy ((==) `on` snd) . + map (pk (fromMaybe (error "dim_mn") . d_nm)) . + dim + +-- | Diatonic interval set to interval set. +-- +-- >>> pct dis 24 +-- 1256 +-- +-- > dis [2,4] == [1,2,5,6] +dis :: (Integral t) => [Int] -> [t] +dis = + let is = [[], [], [1,2], [3,4], [5,6], [6,7], [8,9], [10,11]] + in concatMap (is !!) + +-- | Degree of intersection. +-- +-- >>> echo 024579e | pct doi 6 | sort -u +-- 024579A +-- 024679B +-- +-- > let p = [0,2,4,5,7,9,11] +-- > doi z12 6 p p == [[0,2,4,5,7,9,10],[0,2,4,6,7,9,11]] +-- +-- >>> echo 01234 | pct doi 2 7-35 | sort -u +-- 13568AB +-- +-- > doi z12 2 (sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]] +doi :: Integral i => Z i -> Int -> [i] -> [i] -> [[i]] +doi z n p q = + let f j = [z_tto_tn z j p,z_tto_tni z j p] + xs = concatMap f [0 .. z_modulus z - 1] + in T.set (filter (\x -> length (x `intersect` q) == n) xs) + +-- | Embedded segment search. +-- +-- >>> echo 23A | pct ess 0164325 +-- 2B013A9 +-- 923507A +-- +-- > ess z12 [0,1,6,4,3,2,5] [2,3,10] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]] +ess :: Integral i => Z i -> [i] -> [i] -> [[i]] +ess z p q = filter (`T.is_embedding` q) (z_sro_rtmi_related z p) + +-- | Forte name (ie 'sc_name'). +fn :: Integral i => [i] -> String +fn = sc_name + +-- | Z-12 cycles. +frg_cyc :: Integral i => T.T6 [[i]] +frg_cyc = + let add = z_add z12 + mul = z_mul z12 + c1 = [[0 .. 11]] + c2 = map (\n -> map (add n) [0,2..10]) [0..1] + c3 = map (\n -> map (add n) [0,3..9]) [0..2] + c4 = map (\n -> map (add n) [0,4..8]) [0..3] + c5 = map (map (mul 5)) c1 + c6 = map (\n -> map (add n) [0,6]) [0..5] + in (c1,c2,c3,c4,c5,c6) + +-- | Fragmentation of cycles. +frg :: Integral i => [i] -> T.T6 [String] +frg p = + let f = map (\n -> if n `elem` p then z16_to_char n else '-') + in T.t6_map (map f) frg_cyc + +-- | Header sequence for 'frg_pp'. +frg_hdr :: [String] +frg_hdr = map (\n -> "Fragmentation of " ++ show n ++ "-cycle(s)") [1::Int .. 6] + +{-| Fragmentation of cycles. + +>>> pct frg 024579 +Fragmentation of 1-cycle(s): [0-2-45-7-9--] +Fragmentation of 2-cycle(s): [024---] [--579-] +Fragmentation of 3-cycle(s): [0--9] [-47-] [25--] +Fragmentation of 4-cycle(s): [04-] [-59] [2--] [-7-] +Fragmentation of 5-cycle(s): [05------4927] +Fragmentation of 6-cycle(s): [0-] [-7] [2-] [-9] [4-] [5-] +IC cycle vector: <1> <22> <111> <1100> <5> <000000> + +> putStrLn $ frg_pp [0,2,4,5,7,9] +-} +frg_pp :: Integral i => [i] -> String +frg_pp = + let f = unwords . map (T.bracket ('[',']')) + g x y = x ++ ": " ++ y + in unlines . zipWith g frg_hdr . T.t6_to_list . T.t6_map f . frg + +-- | Can the set-class q (under prime form algorithm pf) be drawn from the pcset p. +has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool +has_sc_pf pf p q = + let n = length q + in pf q `elem` map pf (cf [n] (cg p)) + +-- | 'has_sc_pf' of 'forte_prime' +-- +-- > let d = [0,2,4,5,7,9,11] +-- > has_sc z12 d (z_complement z12 d) == True +-- +-- > has_sc z12 [] [] == True +has_sc :: Integral i => Z i -> [i] -> [i] -> Bool +has_sc z = has_sc_pf (z_forte_prime z) + +-- | Interval-class cycle vector. +ic_cycle_vector :: Integral i => [i] -> T.T6 [Int] +ic_cycle_vector p = + let f str = let str' = if length str > 2 then T.close 1 str else str + in length (filter (\(x,y) -> x /= '-' && y /= '-') (T.adj2 1 str')) + in T.t6_map (map f) (frg p) + +-- | Pretty printer for 'ic_cycle_vector'. +-- +-- > let r = "IC cycle vector: <1> <22> <111> <1100> <5> <000000>" +-- > ic_cycle_vector_pp (ic_cycle_vector [0,2,4,5,7,9]) == r +ic_cycle_vector_pp :: T.T6 [Int] -> String +ic_cycle_vector_pp = ("IC cycle vector: " ++) . unwords . T.t6_to_list . T.t6_map z16_seq_pp + +-- | Interval cycle filter. +-- +-- >>> echo 22341 | pct icf +-- 22341 +-- +-- > icf [[2,2,3,4,1]] == [[2,2,3,4,1]] +icf :: (Num a,Eq a) => [[a]] -> [[a]] +icf = filter ((== 12) . sum) + +-- | Interval class set to interval sets. +-- +-- >>> pct ici -c 123 +-- 123 +-- 129 +-- 1A3 +-- 1A9 +-- +-- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]] +ici :: (Num t) => [Int] -> [[t]] +ici xs = + let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j + ys = map is xs + in cgg ys + +-- | Interval class set to interval sets, concise variant. +-- +-- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]] +ici_c :: [Int] -> [[Int]] +ici_c [] = [] +ici_c (x:xs) = map (x:) (ici xs) + +-- | Interval segment (INT). +iseg :: Integral i => Z i -> [i] -> [i] +iseg z = T.d_dx_by (z_sub z) + +-- | Imbrications. +-- +-- > let r = [[[0,2,4],[2,4,5],[4,5,7],[5,7,9]] +-- > ,[[0,2,4,5],[2,4,5,7],[4,5,7,9]]] +-- > in imb [3,4] [0,2,4,5,7,9] == r +imb :: (Integral n) => [n] -> [a] -> [[[a]]] +imb cs p = + let g n = (== n) . genericLength + f ps n = filter (g n) (map (genericTake n) ps) + in map (f (tails p)) cs + +{- | 'issb' gives the set-classes that can append to 'p' to give 'q'. + +>>> pct issb 3-7 6-32 +3-7 +3-2 +3-11 + +> issb (sc "3-7") (sc "6-32") == ["3-2","3-7","3-11"] + +-} +issb :: Integral i => [i] -> [i] -> [String] +issb p q = + let k = length q - length p + f = any (\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. +-- +-- >>> pct mxs 024579 642 | sort -u +-- 6421B9 +-- B97642 +-- +-- > set (mxs z12 [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]] +mxs :: Integral i => Z i -> [i] -> [i] -> [[i]] +mxs z p q = filter (q `isInfixOf`) (z_sro_rti_related z p) + +-- | Normalize (synonym for 'set') +-- +-- >>> pct nrm 0123456543210 +-- 0123456 +-- +-- > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6] +nrm :: (Ord a) => [a] -> [a] +nrm = T.set + +-- | Normalize, retain duplicate elements. +nrm_r :: (Ord a) => [a] -> [a] +nrm_r = sort + +{- | Pitch-class invariances (called @pi@ at @pct@). + +>>> pct pi 0236 12 +pcseg 0236 +pcseg 6320 +pcseg 532B +pcseg B235 + +> pci z12 [1,2] [0,2,3,6] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]] + +-} +pci :: Integral i => Z i-> [Int] -> [i] -> [[i]] +pci z i p = + let f q = T.set (map (q !!) i) + in filter (\q -> f q == f p) (z_sro_rti_related z p) + +{- | Relate sets (TnMI), ie 'z_tto_rel' + +>>> $ pct rs 0123 641B +>>> T1M + +> map tto_pp (rs 5 z12 [0,1,2,3] [6,4,1,11]) == ["T1M","T4MI"] + +-} +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. + +>>> $ pct rsg 156 3BA +>>> T4I +>>> $ pct rsg 0123 05A3 +>>> T0M +>>> $ pct rsg 0123 4B61 +>>> RT1M +>>> $ pct rsg 0123 B614 +>>> r3RT1M + +> let sros = map (sro_parse 5) . words +> rsg 5 z12 [1,5,6] [3,11,10] == sros "T4I r1RT4MI" +> rsg 5 z12 [0,1,2,3] [0,5,10,3] == sros "T0M RT3MI" +> rsg 5 z12 [0,1,2,3] [4,11,6,1] == sros "T4MI RT1M" +> rsg 5 z12 [0,1,2,3] [11,6,1,4] == sros "r1T4MI r1RT1M" + +-} +rsg :: Integral i => i -> Z i -> [i] -> [i] -> [Sro i] +rsg = 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 (\q -> has_sc z q p) xs + in filter f scs + +{- | scc = set class completion + +>>> pct scc 6-32 168 +35A +49B +3AB +34B + +> scc z12 (sc "6-32") [1,6,8] == [[3,5,10],[4,9,11],[3,10,11],[3,4,11]] + +-} +scc :: Integral i => Z i -> [i] -> [i] -> [[i]] +scc z r p = map (\\ p) (filter (T.is_subset p) (z_tto_ti_related z r)) + +-- | Header fields for 'si'. +si_hdr :: [String] +si_hdr = + ["pitch-class-set" + ,"set-class" + ,"interval-class-vector" + ,"tics" + ,"complement" + ,"multiplication-by-five-transform"] + +-- | (Pcset,Tto,Forte-Prime) +type Si i = ([i],Tto i,[i]) + +-- | Calculator for si. +-- +-- > si_calc [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 = 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 [0,5,3,11] +si_rhs_pp :: (Integral i,Show i) => [i] -> [String] +si_rhs_pp p = + let pf_pp concise (x_o,x_f) = + concat [tto_pp x_o," ",sc_name x_f + ,if concise then "" else z16_vec_pp x_f] + si_pp (x,x_o,x_f) = concat [z16_set_pp x," (",pf_pp True (x_o,x_f),")"] + ((p',p_o,p_f),p_icv,p_tics,c,m) = si_calc p + in [z16_set_pp p' + ,pf_pp False (p_o,p_f) + ,z16_vec_pp p_icv + ,z16_vec_pp p_tics + ,si_pp c + ,si_pp m] + +{- | Set information. + +$ pct si 053b +pitch-class-set: {035B} +set-class: TB 4-Z15[0146] +interval-class-vector: [4111111] +tics: [102222102022] +complement: {1246789A} (TAI 8-Z15) +multiplication-by-five-transform: {0317} (T0 4-Z29) +$ + +> putStr $ unlines $ si [0,5,3,11] +-} +si :: (Integral i,Show i) => [i] -> [String] +si p = zipWith (\k v -> concat [k,": ",v]) si_hdr (si_rhs_pp p) + +{- | Super set-class. + +>>> pct spsc 4-11 4-12 +5-26[02458] + +> spsc z12 [sc "4-11",sc "4-12"] == [[0,2,4,5,8]] + +>>> pct spsc 3-11 3-8 +4-27[0258] +4-Z29[0137] + +> spsc z12 [sc "3-11",sc "3-8"] == [[0,2,5,8],[0,1,3,7]] + +>>> pct spsc `pct fl 3` +6-Z17[012478] + +> spsc z12 (cf [3] scs) == [[0,1,2,4,7,8]] + +-} +spsc :: Integral i => Z i -> [[i]] -> [[i]] +spsc z xs = + let f y = all (has_sc z y) xs + g = (==) `on` length + in (head . groupBy g . filter f) scs + +{- | sra = stravinsky rotational array + +>>> echo 019BA7 | pct sra +019BA7 +08A96B +021A34 +0B812A +0923B1 +056243 + +> let r = [[0,1,9,11,10,7],[0,8,10,9,6,11],[0,2,1,10,3,4],[0,11,8,1,2,10],[0,9,2,3,11,1],[0,5,6,2,4,3]] +> sra z12 [0,1,9,11,10,7] == r + +-} +sra :: Integral i => Z i -> [i] -> [[i]] +sra z = map (z_sro_tn_to z 0) . T.rotations + +{- | Serial operation. + +>>> echo 156 | pct sro T4 +59A + +> sro (Z.sro_parse "T4") [1,5,6] == [5,9,10] + +>>> echo 024579 | pct sro RT4I +79B024 + +> sro (Z.Sro 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4] + +>>> echo 156 | pct sro T4I +3BA + +> sro (Z.sro_parse "T4I") [1,5,6] == [3,11,10] +> sro (Z.Sro 0 False 4 False True) [1,5,6] == [3,11,10] + +>>> echo 156 | pct sro T4 | pct sro T0I +732 + +> (sro (Z.sro_parse "T0I") . sro (Z.sro_parse "T4")) [1,5,6] == [7,3,2] + +>>> echo 024579 | pct sro RT4I +79B024 + +> sro (Z.sro_parse "RT4I") [0,2,4,5,7,9] == [7,9,11,0,2,4] + +-} +sro :: Integral i => Z i -> Sro i -> [i] -> [i] +sro = z_sro_apply + +{- | tmatrix + +>>> pct tmatrix 1258 + +1258 +0147 +9A14 +67A1 + +> tmatrix z12 [1,2,5,8] == [[1,2,5,8],[0,1,4,7],[9,10,1,4],[6,7,10,1]] + +-} +tmatrix :: Integral i => Z i -> [i] -> [[i]] +tmatrix z p = + let i = map (z_negate z) (T.d_dx_by (z_sub z) p) + in map (\n -> map (z_add z n) p) (T.dx_d 0 i) + + +{- | trs = transformations search. Search all RTnMI of /p/ for /q/. + +>>> echo 642 | pct trs 024579 | sort -u +531642 +6421B9 +642753 +B97642 + +> let r = [[5,3,1,6,4,2],[6,4,2,1,11,9],[6,4,2,7,5,3],[11,9,7,6,4,2]] +> sort (trs z12 [0,2,4,5,7,9] [6,4,2]) == r + +-} +trs :: Integral i => Z i -> [i] -> [i] -> [[i]] +trs z p q = filter (q `isInfixOf`) (z_sro_rtmi_related z p) + +-- | Like 'trs', but of 'z_sro_rti_related'. +-- +-- > trs_m z12 [0,2,4,5,7,9] [6,4,2] == [[6,4,2,1,11,9],[11,9,7,6,4,2]] +trs_m :: Integral i => Z i -> [i] -> [i] -> [[i]] +trs_m z p q = filter (q `isInfixOf`) (z_sro_rti_related z p) diff --git a/Music/Theory/Z/Drape_1999/Cli.hs b/Music/Theory/Z/Drape_1999/Cli.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Drape_1999/Cli.hs @@ -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) diff --git a/Music/Theory/Z/Forte_1973.hs b/Music/Theory/Z/Forte_1973.hs --- a/Music/Theory/Z/Forte_1973.hs +++ b/Music/Theory/Z/Forte_1973.hs @@ -1,91 +1,103 @@ --- | Allen Forte. /The Structure of Atonal Music/. Yale University --- Press, New Haven, 1973. +-- | Allen Forte. /The Structure of Atonal Music/. +-- Yale University Press, New Haven, 1973. module Music.Theory.Z.Forte_1973 where +import Data.Bifunctor {- base -} import Data.List {- base -} import Data.Maybe {- base -} -import Music.Theory.List -import qualified Music.Theory.Set.List as S -import Music.Theory.Z -import Music.Theory.Z.SRO +import qualified Music.Theory.List as T {- hmt -} +import qualified Music.Theory.Set.List as S {- hmt -} +import Music.Theory.Unicode {- hmt -} +import Music.Theory.Z {- hmt -} +import Music.Theory.Z.Sro {- hmt -} + -- * Prime form --- | T-related rotations of /p/. +-- | T-related rotations of /p/, ie. all rotations tranposed to be at zero. -- --- > t_rotations 12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]] -t_rotations :: Integral a => a -> [a] -> [[a]] -t_rotations z p = - let r = rotations (sort p) - in map (tn_to z 0) r +-- > z_t_rotations z12 [1,2,4] == [[0,1,3],[0,2,11],[0,9,10]] +z_t_rotations :: Integral i => Z i -> [i] -> [[i]] +z_t_rotations z p = + let r = T.rotations (sort p) + in map (z_sro_tn_to z 0) r -- | T\/I-related rotations of /p/. -- --- > ti_rotations 12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10] --- > ,[0,9,11],[0,2,3],[0,1,10]] -ti_rotations :: Integral a => a -> [a] -> [[a]] -ti_rotations z p = - let q = invert z 0 p - r = rotations (sort p) ++ rotations (sort q) - in map (tn_to z 0) r - --- | Variant with default value for empty input list case. -minimumBy_or :: a -> (a -> a -> Ordering) -> [a] -> a -minimumBy_or p f q = if null q then p else minimumBy f q +-- > ti_rotations z12 [0,1,3] == [[0,1,3],[0,2,11],[0,9,10],[0,9,11],[0,2,3],[0,1,10]] +z_ti_rotations :: Integral i => Z i -> [i] -> [[i]] +z_ti_rotations z p = + let q = z_sro_invert z 0 p + r = T.rotations (sort p) ++ T.rotations (sort q) + in map (z_sro_tn_to z 0) r -- | Prime form rule requiring comparator, considering 't_rotations'. -t_cmp_prime :: Integral a => a -> ([a] -> [a] -> Ordering) -> [a] -> [a] -t_cmp_prime z f = minimumBy_or [] f . t_rotations z +z_t_cmp_prime :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i] +z_t_cmp_prime z f = T.minimumBy_or [] f . z_t_rotations z -- | Prime form rule requiring comparator, considering 'ti_rotations'. -ti_cmp_prime :: Integral a => a -> ([a] -> [a] -> Ordering) -> [a] -> [a] -ti_cmp_prime z f = minimumBy_or [] f . ti_rotations z +z_ti_cmp_prime :: Integral i => Z i -> ([i] -> [i] -> Ordering) -> [i] -> [i] +z_ti_cmp_prime z f = T.minimumBy_or [] f . z_ti_rotations z -- | Forte comparison function (rightmost first then leftmost outwards). -- -- > forte_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == LT forte_cmp :: (Ord t) => [t] -> [t] -> Ordering -forte_cmp [] [] = EQ forte_cmp p q = - let r = compare (last p) (last q) - in if r == EQ then compare p q else r + case (p,q) of + ([],[]) -> EQ + ([],_) -> LT + (_,[]) -> GT + _ -> let r = compare (last p) (last q) + in if r == EQ then compare p q else r --- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'. --- --- > forte_prime 12 [0,1,3,6,8,9] == [0,1,3,6,8,9] --- > forte_prime 5 [0,1,4] == [0,1,2] --- --- > S.set (map (forte_prime 5) (S.powerset [0..4])) -forte_prime :: Integral a => a -> [a] -> [a] -forte_prime z = ti_cmp_prime z forte_cmp +{- | Forte prime form, ie. 'z_ti_cmp_prime' of 'forte_cmp'. --- | Transpositional equivalence prime form, ie. 't_cmp_prime' of --- 'forte_cmp'. +> z_forte_prime z12 [0,1,3,6,8,9] == [0,1,3,6,8,9] +> z_forte_prime z5 [0,1,4] == [0,1,2] +> 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])) +-} +z_forte_prime :: Integral i => Z i -> [i] -> [i] +z_forte_prime z x = + if nub x /= x || map (z_mod z) x /= x + then error "z_forte_prime: invalid input" + else z_ti_cmp_prime z forte_cmp x + +-- | Transpositional equivalence prime form, +-- ie. 'z_t_cmp_prime' of 'forte_cmp'. -- --- > (forte_prime 12 [0,2,3],t_prime 12 [0,2,3]) == ([0,1,3],[0,2,3]) -t_prime :: Integral a => a -> [a] -> [a] -t_prime z = t_cmp_prime z forte_cmp +-- > (z_forte_prime z12 [0,2,3],z_t_prime z12 [0,2,3]) == ([0,1,3],[0,2,3]) +z_t_prime :: Integral i => Z i -> [i] -> [i] +z_t_prime z = z_t_cmp_prime z forte_cmp -- * ICV Metric --- | Interval class of i interval /i/. +-- | Interval class of interval /i/. -- --- > map (ic 5) [1,2,3,4] == [1,2,2,1] --- > map (ic 12) [5,6,7] == [5,6,5] --- > map (ic 12 . to_Z 12) [-13,-1,0,1,13] == [1,1,0,1,1] -ic :: Integral a => a -> a -> a -ic z i = if i <= (z `div` 2) then i else z_sub z z i +-- > map (z_ic z12) [0..12] == [0,1,2,3,4,5,6,5,4,3,2,1,0] +-- > map (z_ic z7) [0..7] == [0,1,2,3,3,2,1,0] +-- > map (z_ic z5) [0..5] == [0,1,2,2,1,0] +-- > map (z_ic z12) [5,6,7] == [5,6,5] +-- > map (z_ic z12) [-13,-1,0,1,13] == [1,1,0,1,1] +z_ic :: Integral i => Z i -> i -> i +z_ic z i = + let j = z_mod z i + m = z_modulus z + in if j <= (m `div` 2) then j else m - j -- | Forte notation for interval class vector. -- --- > icv 12 [0,1,2,4,7,8] == [3,2,2,3,3,2] -icv :: (Integral i, Num n) => i -> [i] -> [n] -icv z s = - let i = map (ic z . uncurry (z_sub z)) (S.pairs s) - j = map f (group (sort i)) - k = map (`lookup` j) [1 .. z `div` 2] +-- > z_icv z12 [0,1,2,4,7,8] == [3,2,2,3,3,2] +z_icv :: (Integral i, Num n) => Z i -> [i] -> [n] +z_icv z s = + let i = map (z_ic z . z_mod z . uncurry (-)) (S.pairs s) f l = (head l,genericLength l) + j = map f (group (sort i)) + k = map (`lookup` j) [1 .. z_modulus z `div` 2] in map (fromMaybe 0) k -- * BIP Metric @@ -96,6 +108,344 @@ -- >>> bip 0t95728e3416 -- 11223344556 -- --- > bip 12 [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6] -bip :: Integral a => a -> [a] -> [a] -bip z = sort . map (ic z . to_Z z) . d_dx +-- > z_bip z12 [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6] +z_bip :: Integral i => Z i -> [i] -> [i] +z_bip z = sort . map (z_ic z . z_mod z) . T.d_dx + +{- | Generate SC universe, though not in order of the Forte table. + +> length (z_sc_univ z7) == 18 +> sort (z_sc_univ z12) == sort (map snd sc_table) +> zipWith (\p q -> (p == q,p,q)) (z_sc_univ z12) (map snd sc_table) + +-} +z_sc_univ :: Integral i => Z i -> [[i]] +z_sc_univ z = + T.sort_by_two_stage_on length id $ + nub $ + map (z_forte_prime z) $ + S.powerset (z_univ z) + +-- * Forte Names (Z12) + +-- | Synonym for 'String'. +type SC_Name = String + +-- | Table of (SC-NAME,PCSET). +type SC_Table n = [(SC_Name,[n])] + +-- | The Z12 set-class table (Forte prime forms). +-- +-- > length sc_table == 224 +sc_table :: Num n => SC_Table n +sc_table = + [("0-1",[]) + ,("1-1",[0]) + ,("2-1",[0,1]) + ,("2-2",[0,2]) + ,("2-3",[0,3]) + ,("2-4",[0,4]) + ,("2-5",[0,5]) + ,("2-6",[0,6]) + ,("3-1",[0,1,2]) + ,("3-2",[0,1,3]) + ,("3-3",[0,1,4]) + ,("3-4",[0,1,5]) + ,("3-5",[0,1,6]) + ,("3-6",[0,2,4]) + ,("3-7",[0,2,5]) + ,("3-8",[0,2,6]) + ,("3-9",[0,2,7]) + ,("3-10",[0,3,6]) + ,("3-11",[0,3,7]) + ,("3-12",[0,4,8]) + ,("4-1",[0,1,2,3]) + ,("4-2",[0,1,2,4]) + ,("4-3",[0,1,3,4]) + ,("4-4",[0,1,2,5]) + ,("4-5",[0,1,2,6]) + ,("4-6",[0,1,2,7]) + ,("4-7",[0,1,4,5]) + ,("4-8",[0,1,5,6]) + ,("4-9",[0,1,6,7]) + ,("4-10",[0,2,3,5]) + ,("4-11",[0,1,3,5]) + ,("4-12",[0,2,3,6]) + ,("4-13",[0,1,3,6]) + ,("4-14",[0,2,3,7]) + ,("4-Z15",[0,1,4,6]) + ,("4-16",[0,1,5,7]) + ,("4-17",[0,3,4,7]) + ,("4-18",[0,1,4,7]) + ,("4-19",[0,1,4,8]) + ,("4-20",[0,1,5,8]) + ,("4-21",[0,2,4,6]) + ,("4-22",[0,2,4,7]) + ,("4-23",[0,2,5,7]) + ,("4-24",[0,2,4,8]) + ,("4-25",[0,2,6,8]) + ,("4-26",[0,3,5,8]) + ,("4-27",[0,2,5,8]) + ,("4-28",[0,3,6,9]) + ,("4-Z29",[0,1,3,7]) + ,("5-1",[0,1,2,3,4]) + ,("5-2",[0,1,2,3,5]) + ,("5-3",[0,1,2,4,5]) + ,("5-4",[0,1,2,3,6]) + ,("5-5",[0,1,2,3,7]) + ,("5-6",[0,1,2,5,6]) + ,("5-7",[0,1,2,6,7]) + ,("5-8",[0,2,3,4,6]) + ,("5-9",[0,1,2,4,6]) + ,("5-10",[0,1,3,4,6]) + ,("5-11",[0,2,3,4,7]) + ,("5-Z12",[0,1,3,5,6]) + ,("5-13",[0,1,2,4,8]) + ,("5-14",[0,1,2,5,7]) + ,("5-15",[0,1,2,6,8]) + ,("5-16",[0,1,3,4,7]) + ,("5-Z17",[0,1,3,4,8]) + ,("5-Z18",[0,1,4,5,7]) + ,("5-19",[0,1,3,6,7]) + ,("5-20",[0,1,3,7,8]) + ,("5-21",[0,1,4,5,8]) + ,("5-22",[0,1,4,7,8]) + ,("5-23",[0,2,3,5,7]) + ,("5-24",[0,1,3,5,7]) + ,("5-25",[0,2,3,5,8]) + ,("5-26",[0,2,4,5,8]) + ,("5-27",[0,1,3,5,8]) + ,("5-28",[0,2,3,6,8]) + ,("5-29",[0,1,3,6,8]) + ,("5-30",[0,1,4,6,8]) + ,("5-31",[0,1,3,6,9]) + ,("5-32",[0,1,4,6,9]) + ,("5-33",[0,2,4,6,8]) + ,("5-34",[0,2,4,6,9]) + ,("5-35",[0,2,4,7,9]) + ,("5-Z36",[0,1,2,4,7]) + ,("5-Z37",[0,3,4,5,8]) + ,("5-Z38",[0,1,2,5,8]) + ,("6-1",[0,1,2,3,4,5]) + ,("6-2",[0,1,2,3,4,6]) + ,("6-Z3",[0,1,2,3,5,6]) + ,("6-Z4",[0,1,2,4,5,6]) + ,("6-5",[0,1,2,3,6,7]) + ,("6-Z6",[0,1,2,5,6,7]) + ,("6-7",[0,1,2,6,7,8]) + ,("6-8",[0,2,3,4,5,7]) + ,("6-9",[0,1,2,3,5,7]) + ,("6-Z10",[0,1,3,4,5,7]) + ,("6-Z11",[0,1,2,4,5,7]) + ,("6-Z12",[0,1,2,4,6,7]) + ,("6-Z13",[0,1,3,4,6,7]) + ,("6-14",[0,1,3,4,5,8]) + ,("6-15",[0,1,2,4,5,8]) + ,("6-16",[0,1,4,5,6,8]) + ,("6-Z17",[0,1,2,4,7,8]) + ,("6-18",[0,1,2,5,7,8]) + ,("6-Z19",[0,1,3,4,7,8]) + ,("6-20",[0,1,4,5,8,9]) + ,("6-21",[0,2,3,4,6,8]) + ,("6-22",[0,1,2,4,6,8]) + ,("6-Z23",[0,2,3,5,6,8]) + ,("6-Z24",[0,1,3,4,6,8]) + ,("6-Z25",[0,1,3,5,6,8]) + ,("6-Z26",[0,1,3,5,7,8]) + ,("6-27",[0,1,3,4,6,9]) + ,("6-Z28",[0,1,3,5,6,9]) + ,("6-Z29",[0,1,3,6,8,9]) + ,("6-30",[0,1,3,6,7,9]) + ,("6-31",[0,1,3,5,8,9]) + ,("6-32",[0,2,4,5,7,9]) + ,("6-33",[0,2,3,5,7,9]) + ,("6-34",[0,1,3,5,7,9]) + ,("6-35",[0,2,4,6,8,10]) + ,("6-Z36",[0,1,2,3,4,7]) + ,("6-Z37",[0,1,2,3,4,8]) + ,("6-Z38",[0,1,2,3,7,8]) + ,("6-Z39",[0,2,3,4,5,8]) + ,("6-Z40",[0,1,2,3,5,8]) + ,("6-Z41",[0,1,2,3,6,8]) + ,("6-Z42",[0,1,2,3,6,9]) + ,("6-Z43",[0,1,2,5,6,8]) + ,("6-Z44",[0,1,2,5,6,9]) + ,("6-Z45",[0,2,3,4,6,9]) + ,("6-Z46",[0,1,2,4,6,9]) + ,("6-Z47",[0,1,2,4,7,9]) + ,("6-Z48",[0,1,2,5,7,9]) + ,("6-Z49",[0,1,3,4,7,9]) + ,("6-Z50",[0,1,4,6,7,9]) + ,("7-1",[0,1,2,3,4,5,6]) + ,("7-2",[0,1,2,3,4,5,7]) + ,("7-3",[0,1,2,3,4,5,8]) + ,("7-4",[0,1,2,3,4,6,7]) + ,("7-5",[0,1,2,3,5,6,7]) + ,("7-6",[0,1,2,3,4,7,8]) + ,("7-7",[0,1,2,3,6,7,8]) + ,("7-8",[0,2,3,4,5,6,8]) + ,("7-9",[0,1,2,3,4,6,8]) + ,("7-10",[0,1,2,3,4,6,9]) + ,("7-11",[0,1,3,4,5,6,8]) + ,("7-Z12",[0,1,2,3,4,7,9]) + ,("7-13",[0,1,2,4,5,6,8]) + ,("7-14",[0,1,2,3,5,7,8]) + ,("7-15",[0,1,2,4,6,7,8]) + ,("7-16",[0,1,2,3,5,6,9]) + ,("7-Z17",[0,1,2,4,5,6,9]) + ,("7-Z18",[0,1,2,3,5,8,9]) + ,("7-19",[0,1,2,3,6,7,9]) + ,("7-20",[0,1,2,4,7,8,9]) + ,("7-21",[0,1,2,4,5,8,9]) + ,("7-22",[0,1,2,5,6,8,9]) + ,("7-23",[0,2,3,4,5,7,9]) + ,("7-24",[0,1,2,3,5,7,9]) + ,("7-25",[0,2,3,4,6,7,9]) + ,("7-26",[0,1,3,4,5,7,9]) + ,("7-27",[0,1,2,4,5,7,9]) + ,("7-28",[0,1,3,5,6,7,9]) + ,("7-29",[0,1,2,4,6,7,9]) + ,("7-30",[0,1,2,4,6,8,9]) + ,("7-31",[0,1,3,4,6,7,9]) + ,("7-32",[0,1,3,4,6,8,9]) + ,("7-33",[0,1,2,4,6,8,10]) + ,("7-34",[0,1,3,4,6,8,10]) + ,("7-35",[0,1,3,5,6,8,10]) + ,("7-Z36",[0,1,2,3,5,6,8]) + ,("7-Z37",[0,1,3,4,5,7,8]) + ,("7-Z38",[0,1,2,4,5,7,8]) + ,("8-1",[0,1,2,3,4,5,6,7]) + ,("8-2",[0,1,2,3,4,5,6,8]) + ,("8-3",[0,1,2,3,4,5,6,9]) + ,("8-4",[0,1,2,3,4,5,7,8]) + ,("8-5",[0,1,2,3,4,6,7,8]) + ,("8-6",[0,1,2,3,5,6,7,8]) + ,("8-7",[0,1,2,3,4,5,8,9]) + ,("8-8",[0,1,2,3,4,7,8,9]) + ,("8-9",[0,1,2,3,6,7,8,9]) + ,("8-10",[0,2,3,4,5,6,7,9]) + ,("8-11",[0,1,2,3,4,5,7,9]) + ,("8-12",[0,1,3,4,5,6,7,9]) + ,("8-13",[0,1,2,3,4,6,7,9]) + ,("8-14",[0,1,2,4,5,6,7,9]) + ,("8-Z15",[0,1,2,3,4,6,8,9]) + ,("8-16",[0,1,2,3,5,7,8,9]) + ,("8-17",[0,1,3,4,5,6,8,9]) + ,("8-18",[0,1,2,3,5,6,8,9]) + ,("8-19",[0,1,2,4,5,6,8,9]) + ,("8-20",[0,1,2,4,5,7,8,9]) + ,("8-21",[0,1,2,3,4,6,8,10]) + ,("8-22",[0,1,2,3,5,6,8,10]) + ,("8-23",[0,1,2,3,5,7,8,10]) + ,("8-24",[0,1,2,4,5,6,8,10]) + ,("8-25",[0,1,2,4,6,7,8,10]) + ,("8-26",[0,1,2,4,5,7,9,10]) + ,("8-27",[0,1,2,4,5,7,8,10]) + ,("8-28",[0,1,3,4,6,7,9,10]) + ,("8-Z29",[0,1,2,3,5,6,7,9]) + ,("9-1",[0,1,2,3,4,5,6,7,8]) + ,("9-2",[0,1,2,3,4,5,6,7,9]) + ,("9-3",[0,1,2,3,4,5,6,8,9]) + ,("9-4",[0,1,2,3,4,5,7,8,9]) + ,("9-5",[0,1,2,3,4,6,7,8,9]) + ,("9-6",[0,1,2,3,4,5,6,8,10]) + ,("9-7",[0,1,2,3,4,5,7,8,10]) + ,("9-8",[0,1,2,3,4,6,7,8,10]) + ,("9-9",[0,1,2,3,5,6,7,8,10]) + ,("9-10",[0,1,2,3,4,6,7,9,10]) + ,("9-11",[0,1,2,3,5,6,7,9,10]) + ,("9-12",[0,1,2,4,5,6,8,9,10]) + ,("10-1",[0,1,2,3,4,5,6,7,8,9]) + ,("10-2",[0,1,2,3,4,5,6,7,8,10]) + ,("10-3",[0,1,2,3,4,5,6,7,9,10]) + ,("10-4",[0,1,2,3,4,5,6,8,9,10]) + ,("10-5",[0,1,2,3,4,5,7,8,9,10]) + ,("10-6",[0,1,2,3,4,6,7,8,9,10]) + ,("11-1",[0,1,2,3,4,5,6,7,8,9,10]) + ,("12-1",[0,1,2,3,4,5,6,7,8,9,10,11])] + +-- | Unicode (non-breaking hyphen) variant. +sc_table_unicode :: Num n => SC_Table n +sc_table_unicode = + let f = map (\c -> if c == '-' then non_breaking_hypen else c) + 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. +-- +-- > forte_prime_name [0,1,4,6] == ("4-Z15",[0,1,4,6]) +forte_prime_name :: (Num n,Eq n) => [n] -> (SC_Name,[n]) +forte_prime_name p = fromMaybe (error "forte_prime_name") (find (\(_,q) -> p == q) sc_table) + +-- | Lookup entry for set in table. +sc_tbl_lookup :: Integral i => SC_Table i -> [i] -> Maybe (SC_Name,[i]) +sc_tbl_lookup tbl p = find (\(_,q) -> z_forte_prime z12 p == q) tbl + +-- | Erroring variant +sc_tbl_lookup_err :: Integral i => SC_Table i -> [i] -> (SC_Name,[i]) +sc_tbl_lookup_err tbl = fromMaybe (error "sc_tbl_lookup") . sc_tbl_lookup tbl + +-- | 'fst' of 'sc_tbl_lookup_err' +sc_name_tbl :: Integral i => SC_Table i -> [i] -> SC_Name +sc_name_tbl tbl = fst . sc_tbl_lookup_err tbl + +-- | Lookup a set-class name. The input set is subject to +-- 'forte_prime' of 'z12' before lookup. +-- +-- > sc_name [0,2,3,6,7] == "5-Z18" +-- > sc_name [0,1,4,6,7,8] == "6-Z17" +sc_name :: Integral i => [i] -> SC_Name +sc_name = sc_name_tbl sc_table + +-- | Long name (ie. with enumeration of prime form). +-- +-- > sc_name_long [0,1,4,6,7,8] == "6-Z17[012478]" +sc_name_long :: Integral i => [i] -> SC_Name +sc_name_long p = + let (nm,p') = sc_tbl_lookup_err sc_table p + in nm ++ z16_vec_pp p' + +-- | Unicode (non-breaking hyphen) variant. +sc_name_unicode :: Integral i => [i] -> SC_Name +sc_name_unicode = sc_name_tbl sc_table_unicode + +-- | Lookup a set-class given a set-class name. +-- +-- > sc "6-Z17" == [0,1,2,4,7,8] +sc :: Num n => SC_Name -> [n] +sc n = snd (fromMaybe (error "sc") (find (\(m,_) -> n == m) sc_table)) + +-- | The set-class table (Forte prime forms), ie. 'snd' of 'sc_table'. +scs :: Num n => [[n]] +scs = map snd sc_table + +-- | Cardinality /n/ subset of 'scs'. +-- +-- > map (length . scs_n) [1..11] == [1,6,12,29,38,50,38,29,12,6,1] +scs_n :: (Integral i, Num n) => i -> [[n]] +scs_n n = filter ((== n) . genericLength) scs + +-- | Vector indicating degree of intersection with inversion at each transposition. +-- +-- > tics z12 [0,2,4,5,7,9] == [3,2,5,0,5,2,3,4,1,6,1,4] +-- > map (tics z12) scs +tics :: Integral i => Z i -> [i] -> [Int] +tics z p = + let q = z_sro_t_related z (z_sro_invert z 0 p) + in map (length . intersect p) q + +-- * Z-relation + +-- | Locate /Z/ relation of set class. +-- +-- > fmap sc_name (z_relation_of (sc "7-Z12")) == Just "7-Z36" +z_relation_of :: Integral i => [i] -> Maybe [i] +z_relation_of x = + let n = length x + eq_i :: [Integer] -> [Integer] -> Bool + eq_i = (==) + f y = (x /= y) && (z_icv z12 x `eq_i` z_icv z12 y) + in case filter f (scs_n n) of + [] -> Nothing + [r] -> Just r + _ -> error "z_relation_of" diff --git a/Music/Theory/Z/Lewin_1980.hs b/Music/Theory/Z/Lewin_1980.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Lewin_1980.hs @@ -0,0 +1,50 @@ +-- | David Lewin. \"A Response to a Response: On PC Set +-- Relatedness\". /Perspectives of New Music/, 18(1-2):498-502, 1980. +module Music.Theory.Z.Lewin_1980 where + +import Data.Int {- base -} +import Data.List {- base -} + +import qualified Music.Theory.Z.Castren_1994 as Castren + +type Z12 = Int8 + +-- | REL function with given /ncv/ function (see 't_rel' and 'ti_rel'). +rel :: Floating n => (Int -> [a] -> [n]) -> [a] -> [a] -> n +rel ncv x y = + let n = min (genericLength x) (genericLength y) + p = map (`ncv` x) [2..n] + q = map (`ncv` y) [2..n] + f = zipWith (\i j -> sqrt (i * j)) + pt = sum (map sum p) + qt = sum (map sum q) + in sum (map sum (zipWith f p q)) / sqrt (pt * qt) + +-- | T-equivalence REL function. +-- +-- Kuusi 2001, 7.5.2 +-- +-- > let (~=) p q = abs (p - q) < 0.001 +-- > t_rel [0,1,2,3,4] [0,2,3,6,7] ~= 0.429 +-- > t_rel [0,1,2,3,4] [0,2,4,6,8] ~= 0.253 +-- > t_rel [0,2,3,6,7] [0,2,4,6,8] ~= 0.324 +t_rel :: Floating n => [Z12] -> [Z12] -> n +t_rel = rel Castren.t_n_class_vector + +-- | T/I-equivalence REL function. +-- +-- Buchler 1998, Fig. 3.38 +-- +-- > let (~=) p q = abs (p - q) < 0.001 +-- > let a = [0,2,3,5,7]::[Z12] +-- > let b = [0,2,3,4,5,8]::[Z12] +-- > let g = [0,1,2,3,5,6,8,10]::[Z12] +-- > let j = [0,2,3,4,5,6,8]::[Z12] +-- > ti_rel a b ~= 0.593 +-- > ti_rel a g ~= 0.648 +-- > ti_rel a j ~= 0.509 +-- > ti_rel b g ~= 0.712 +-- > ti_rel b j ~= 0.892 +-- > ti_rel g j ~= 0.707 +ti_rel :: Floating n => [Z12] -> [Z12] -> n +ti_rel = rel Castren.ti_n_class_vector diff --git a/Music/Theory/Z/Literature.hs b/Music/Theory/Z/Literature.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Literature.hs @@ -0,0 +1,48 @@ +-- | Z12 set class database. +module Music.Theory.Z.Literature where + +-- | Set class database with descriptors for historically and +-- theoretically significant set classes, indexed by Forte name. +-- +-- > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord" +-- > lookup "7-35" sc_db == Just "diatonic collection (d)" +sc_db :: [(String,String)] +sc_db = + [("4-Z15","All-Interval Tetrachord (see also 4-Z29)") + ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)") + ,("6-Z17","All-Trichord Hexachord") + ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)") + ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)") + ,("6-1","A-Type All-Combinatorial Hexachord") + ,("6-8","B-Type All-Combinatorial Hexachord") + ,("6-32","C-Type All-Combinatorial Hexachord") + ,("6-7","D-Type All-Combinatorial Hexachord") + ,("6-20","E-Type All-Combinatorial Hexachord") + ,("6-35","F-Type All-Combinatorial Hexachord") + ,("7-35","diatonic collection (d)") + ,("7-34","ascending melodic minor collection") + ,("8-28","octotonic collection (Messiaen Mode II)") + ,("6-35","wholetone collection") + ,("3-10","diminished triad") + ,("3-11","major/minor triad") + ,("3-12","augmented triad") + ,("4-19","minor major-seventh chord") + ,("4-20","major-seventh chord") + ,("4-25","french augmented sixth chord") + ,("4-28","dimished-seventh chord") + ,("4-26","minor-seventh chord") + ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord") + ,("6-30","Petrushka Chord {0476a1},3-11 at T6") + ,("6-34","Mystic Chord {06a492}") + ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7") + ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB") + ,("9-12","Messiaen Mode III (nontonic collection)") + ,("8-9","Messian Mode IV") + ,("7-31","The only seven-element subset of 8-28. ") + ,("5-31","The only five-element superset of 4-28.") + ,("5-33","The only five-element subset of 6-35.") + ,("7-33","The only seven-element superset of 6-35.") + ,("5-21","The only five-element subset of 6-20.") + ,("7-21","The only seven-element superset of 6-20.") + ,("5-25","The only five-element subset of both 7-35 and 8-28.") + ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ] diff --git a/Music/Theory/Z/Morris_1974.hs b/Music/Theory/Z/Morris_1974.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Morris_1974.hs @@ -0,0 +1,49 @@ +-- | Robert Morris and D. Starr. \"The Structure of All-Interval Series\". +-- /Journal of Music Theory/, 18:364-389, 1974. +module Music.Theory.Z.Morris_1974 where + +import Control.Monad {- base -} + +import qualified Control.Monad.Logic as L {- logict -} + +-- | 'msum' '.' 'map' 'return'. +-- +-- > L.observeAll (fromList [1..7]) == [1..7] +fromList :: MonadPlus m => [a] -> m a +fromList = msum . map return + +-- | Interval from /i/ to /j/ in modulo-/n/. +-- +-- > let f = int_n 12 in (f 0 11,f 11 0) == (11,1) +int_n :: Integral a => a -> a -> a -> a +int_n n i j = abs ((j - i) `mod` n) + +-- | 'L.MonadLogic' all-interval series. +-- +-- > map (length . L.observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288] +-- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` L.observeAll (all_interval_m 12) +-- > length (L.observeAll (all_interval_m 12)) == 3856 +all_interval_m :: (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] + guard (i `notElem` p) + let j = head p + m = int_n n i j + guard (m `notElem` q) + recur (k + 1) (i : p) (m : q) + in recur 1 [0] [] + +{- | 'L.observeAll' of 'all_interval_m'. + +> let r = [[0,1,5,2,4,3],[0,2,1,4,5,3],[0,4,5,2,1,3],[0,5,1,4,2,3]] +> all_interval 6 == r + +> d_dx_n n l = zipWith (int_n n) l (tail l) +> map (d_dx_n 6) r == [[1,4,3,2,5],[2,5,3,1,4],[4,1,3,5,2],[5,2,3,4,1]] + +-} +all_interval :: Int -> [[Int]] +all_interval = L.observeAll . all_interval_m diff --git a/Music/Theory/Z/Morris_1987.hs b/Music/Theory/Z/Morris_1987.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Morris_1987.hs @@ -0,0 +1,12 @@ +-- | Robert Morris. /Composition with Pitch-Classes: A Theory of +-- Compositional Design/. Yale University Press, New Haven, 1987. +module Music.Theory.Z.Morris_1987 where + +import Music.Theory.List {- hmt -} +import Music.Theory.Z {- hmt -} + +-- | @INT@ operator. +-- +-- > map (int z12) [[0,1,3,6,10],[3,7,0]] == [[1,2,3,4],[4,5]] +int :: Integral i => Z i -> [i] -> [i] +int z = d_dx_by (z_sub z) diff --git a/Music/Theory/Z/Morris_1987/Parse.hs b/Music/Theory/Z/Morris_1987/Parse.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Morris_1987/Parse.hs @@ -0,0 +1,19 @@ +-- | Parsers for pitch class sets and sequences, and for 'SRO's. +module Music.Theory.Z.Morris_1987.Parse where + +import Data.Char {- base -} + +-- | Parse a /pitch class object/ string. Each 'Char' is either a +-- number, a space which is ignored, or a letter name for the numbers +-- 10 ('t' or 'a' or 'A') or 11 ('e' or 'B' or 'b'). +-- +-- > pco "13te" == [1,3,10,11] +-- > pco "13te" == pco "13ab" +pco :: Num n => String -> [n] +pco s = + let s' = dropWhile isSpace s + s'' = takeWhile (`elem` "0123456789taAebB") s' + f c | c `elem` "taA" = 10 + | c `elem` "ebB" = 11 + | otherwise = fromInteger (read [c]) + in map f s'' diff --git a/Music/Theory/Z/Rahn_1980.hs b/Music/Theory/Z/Rahn_1980.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Rahn_1980.hs @@ -0,0 +1,29 @@ +-- | John Rahn. /Basic Atonal Theory/. Longman, New York, 1980. +module Music.Theory.Z.Rahn_1980 where + +import qualified Music.Theory.Z.Forte_1973 as Forte_1973 {- hmt -} +import Music.Theory.Z {- hmt -} + +-- | Rahn prime form (comparison is rightmost inwards). +-- +-- > rahn_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == GT +rahn_cmp :: Ord a => [a] -> [a] -> Ordering +rahn_cmp p q = compare (reverse p) (reverse q) + +-- | Rahn prime form, ie. 'Forte_1973.ti_cmp_prime' of 'rahn_cmp'. +-- +-- > z_rahn_prime z12 [0,1,3,6,8,9] == [0,2,3,6,7,9] +z_rahn_prime :: Integral i => Z i -> [i] -> [i] +z_rahn_prime z = Forte_1973.z_ti_cmp_prime z rahn_cmp + +-- | The six sets where the Forte and Rahn prime forms differ. +-- Given here in Forte prime form. +-- +-- > all (\p -> Forte_1973.forte_prime z12 p /= rahn_prime z12 p) rahn_forte_diff == True +rahn_forte_diff :: Num n => [[n]] +rahn_forte_diff = + [[0,1,3,7,8] -- #5 + ,[0,1,3,5,8,9],[0,1,3,6,8,9] -- #6 + ,[0,1,2,4,7,8,9],[0,1,2,3,5,8,9] -- #7 + ,[0,1,2,4,5,7,9,10] -- #8 + ] diff --git a/Music/Theory/Z/Read_1978.hs b/Music/Theory/Z/Read_1978.hs --- a/Music/Theory/Z/Read_1978.hs +++ b/Music/Theory/Z/Read_1978.hs @@ -5,83 +5,101 @@ import Data.Bits {- base -} import Data.Char {- base -} -import Data.Function {- base -} import Data.List {- base -} import Data.Maybe {- base -} +import Data.Word {- base -} -import qualified Music.Theory.Z.SRO as T {- hmt -} +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 -} -- | Coding. -type Code = Int +type Code = Word64 +-- | Number of bits at 'Code'. +code_len :: Num n => n +code_len = 64 + -- | Bit array. -type Array = [Bool] +type Bit_Array = [Bool] --- | Pretty printer for 'Array'. -array_pp :: Array -> String -array_pp = map intToDigit . map fromEnum +-- | Logical complement. +bit_array_complement :: Bit_Array -> Bit_Array +bit_array_complement = map not --- | Parse PP of 'Array'. +-- | Pretty printer for 'Bit_Array'. +bit_array_pp :: Bit_Array -> String +bit_array_pp = map (intToDigit . fromEnum) + +-- | Parse PP of 'Bit_Array'. -- --- > parse_array "01001" == [False,True,False,False,True] -parse_array :: String -> Array -parse_array = map (toEnum . digitToInt) +-- > bit_array_parse "01001" == [False,True,False,False,True] +bit_array_parse :: String -> Bit_Array +bit_array_parse = map (toEnum . digitToInt) --- | Generate 'Code' from 'Array', the coding is most to least significant. +-- * MSB (BIG-ENDIAN) + +-- | Generate 'Code' from 'Bit_Array', the coding is most to least significant. -- --- > array_to_code (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == 6428 -array_to_code :: Array -> Code -array_to_code a = - let n = length a - f e j = if e then 2 ^ (n - j - 1) else 0 - in sum (zipWith f a [0..]) +-- > map (bit_array_to_code . bit_array_parse) (words "000 001 010 011 100 101 110 111") == [0..7] +-- > bit_array_to_code (bit_array_parse "1100100011100") == 6428 +bit_array_to_code :: Bit_Array -> Code +bit_array_to_code a = + let n = length a + f e j = if e then 2 ^ (n - j - 1) else 0 + in if n > code_len + then error "bit_array_to_code: > SZ" + else sum (zipWith f a [0..]) --- | Inverse of 'array_to_code'. +-- | Inverse of 'bit_array_to_code'. -- --- > code_to_array 13 6428 == map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0] -code_to_array :: Int -> Code -> Array -code_to_array n c = map (testBit c) [n - 1, n - 2 .. 0] +-- > code_to_bit_array 13 6428 == bit_array_parse "1100100011100" +code_to_bit_array :: Int -> Code -> Bit_Array +code_to_bit_array n c = + if n > code_len + then error "code_to_bit_array: > SZ" + else map (testBit c) [n - 1, n - 2 .. 0] --- | Array to set. +-- | 'Bit_Array' to set. -- --- > array_to_set (map toEnum [1,1,0,0,1,0,0,0,1,1,1,0,0]) == [0,1,4,8,9,10] --- > T.encode [0,1,4,8,9,10] == 1811 -array_to_set :: Integral i => [Bool] -> [i] -array_to_set = +-- > bit_array_to_set (bit_array_parse "1100100011100") == [0,1,4,8,9,10] +-- > set_to_code 13 [0,1,4,8,9,10] == 6428 +bit_array_to_set :: Integral i => Bit_Array -> [i] +bit_array_to_set = let f (i,e) = if e then Just i else Nothing in mapMaybe f . zip [0..] --- | Inverse of 'array_to_set', /z/ is the degree of the array. -set_to_array :: Integral i => i -> [i] -> Array -set_to_array z p = map (`elem` p) [0 .. z - 1] +-- | Inverse of 'bit_array_to_set', /z/ is the degree of the array. +set_to_bit_array :: Integral i => i -> [i] -> Bit_Array +set_to_bit_array z p = + if z > code_len + then error "set_to_bit_array: > SZ" + else map (`elem` p) [0 .. z - 1] --- | 'array_to_code' of 'set_to_array'. +-- | 'bit_array_to_code' of 'set_to_bit_array'. -- --- > set_to_code 12 [0,2,3,5] --- > map (set_to_code 12) (T.ti_related 12 [0,2,3,5]) +-- > 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]) set_to_code :: Integral i => i -> [i] -> Code -set_to_code z = array_to_code . set_to_array z - --- | Logical complement. -array_complement :: Array -> Array -array_complement = map not +set_to_code z = bit_array_to_code . set_to_bit_array z -- | The /prime/ form is the 'maximum' encoding. -- --- > array_is_prime (set_to_array 12 [0,2,3,5]) == False -array_is_prime :: Array -> Bool -array_is_prime a = - let c = array_to_code a - p = array_to_set a - z = length a - u = maximum (map (set_to_code z) (T.ti_related z p)) +-- > bit_array_is_prime (set_to_bit_array 12 [0,2,3,5]) == False +bit_array_is_prime :: Bit_Array -> Bool +bit_array_is_prime a = + let c = bit_array_to_code a + p = bit_array_to_set a + n = length a + z = Z.Z n + u = maximum (map (set_to_code n) (Sro.z_sro_ti_related z p)) in c == u -- | The augmentation rule adds @1@ in each empty slot at end of array. -- --- > map array_pp (array_augment (parse_array "01000")) == ["01100","01010","01001"] -array_augment :: Array -> [Array] -array_augment a = +-- > map bit_array_pp (bit_array_augment (bit_array_parse "01000")) == ["01100","01010","01001"] +bit_array_augment :: Bit_Array -> [Bit_Array] +bit_array_augment a = let (z,a') = break id (reverse a) a'' = reverse a' n = length z @@ -90,55 +108,61 @@ in map (a'' ++) x -- | Enumerate first half of the set-classes under given /prime/ function. --- The second half can be derived as the complement of the first. +-- The second half can be derived as the complement of the first. -- --- > import Music.Theory.Z12.Forte_1973 +-- > import Music.Theory.Z.Forte_1973 -- > length scs == 224 -- > map (length . scs_n) [0..12] == [1,1,6,12,29,38,50,38,29,12,6,1,1] -- --- > let z12 = map (fmap (map array_to_set)) (enumerate_half array_is_prime 12) +-- > let z12 = map (fmap (map bit_array_to_set)) (enumerate_half bit_array_is_prime 12) -- > map (length . snd) z12 == [1,1,6,12,29,38,50] -- -- This can become slow, edit /z/ to find out. It doesn't matter -- about /n/. This can be edited so that small /n/ would run quickly -- even for large /z/. -- --- > fmap (map array_to_set) (lookup 5 (enumerate_half array_is_prime 16)) -enumerate_half :: (Array -> Bool) -> Int -> [(Int,[Array])] +-- > fmap (map bit_array_to_set) (lookup 5 (enumerate_half bit_array_is_prime 16)) +enumerate_half :: (Bit_Array -> Bool) -> Int -> [(Int,[Bit_Array])] enumerate_half pr n = let a0 = replicate n False f k a = if k >= n `div` 2 then [] - else let r = filter pr (array_augment a) + else let r = filter pr (bit_array_augment a) in (k + 1,r) : concatMap (f (k + 1)) r jn l = case l of (x,y):l' -> (x,concat (y : map snd l')) _ -> error "" - post_proc = map jn . groupBy ((==) `on` fst) . sortBy (compare `on` fst) + post_proc = map jn . List.group_on fst . sortOn fst in post_proc ((0,[a0]) : f 0 a0) --- * Alternate (reverse) form. +-- * LSB - LITTLE-ENDIAN +-- | If the size of the set is '>' 'code_len' then 'error', else 'id'. +set_coding_validate :: [t] -> [t] +set_coding_validate l = if length l <= code_len then l else error "set_coding_validate: SIZE" + -- | Encoder for 'encode_prime'. -- --- > encode [0,1,3,6,8,9] == 843 -encode :: Integral i => [i] -> Code -encode = sum . map (2 ^) +-- > map set_encode [[0,1,3,7,8],[0,1,3,6,8,9]] == [395,843] +-- +-- > map (set_to_code 12) [[0,1,3,7,8],[0,1,3,6,8,9]] == [3352,3372] +set_encode :: Integral i => [i] -> Code +set_encode = sum . map (2 ^) . set_coding_validate -- | Decoder for 'encode_prime'. -- --- > decode 12 843 == [0,1,3,6,8,9] -decode :: Integral i => i -> Code -> [i] -decode z n = - let f i = (i,testBit n (fromIntegral i)) +-- > map (set_decode 12) [395,843] == [[0,1,3,7,8],[0,1,3,6,8,9]] +set_decode :: Integral i => Int -> Code -> [i] +set_decode z n = + let f i = (fromIntegral i,testBit n i) in map fst (filter snd (map f [0 .. z - 1])) -- | Binary encoding prime form algorithm, equalivalent to Rahn. -- --- > encode_prime 12 [0,1,3,6,8,9] == [0,2,3,6,7,9] --- > Music.Theory.Z12.Rahn_1980.rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] -encode_prime :: Integral i => i -> [i] -> [i] -encode_prime z s = - let t = map (\n -> T.tn z n s) [0..11] - c = t ++ map (T.invert z 0) t - in decode z (minimum (map encode c)) +-- > set_encode_prime Z.z12 [0,1,3,6,8,9] == [0,2,3,6,7,9] +-- > Music.Theory.Z.Rahn_1980.rahn_prime Z.z12 [0,1,3,6,8,9] == [0,2,3,6,7,9] +set_encode_prime :: Integral i => Z.Z i -> [i] -> [i] +set_encode_prime z s = + let t = map (\x -> Sro.z_sro_tn z x s) (Z.z_univ z) + c = t ++ map (Sro.z_sro_invert z 0) t + in set_decode (fromIntegral (Z.z_modulus z)) (minimum (map set_encode c)) diff --git a/Music/Theory/Z/SRO.hs b/Music/Theory/Z/SRO.hs deleted file mode 100644 --- a/Music/Theory/Z/SRO.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | Serial (ordered) pitch-class operations on 'Z'. -module Music.Theory.Z.SRO where - -import Data.List {- base -} - -import Music.Theory.Z - --- | Transpose /p/ by /n/. --- --- > tn 5 4 [0,1,4] == [4,0,3] --- > tn 12 4 [1,5,6] == [5,9,10] -tn :: (Integral i, Functor f) => i -> i -> f i -> f i -tn z n = fmap (z_add z n) - --- | Invert /p/ about /n/. --- --- > invert 5 0 [0,1,4] == [0,4,1] --- > invert 12 6 [4,5,6] == [8,7,6] --- > invert 12 0 [0,1,3] == [0,11,9] -invert :: (Integral i, Functor f) => i -> i -> f i -> f i -invert z n = fmap (\p -> z_sub z n (z_sub z p n)) - --- | Composition of 'invert' about @0@ and 'tn'. --- --- > tni 5 1 [0,1,3] == [1,0,3] --- > tni 12 4 [1,5,6] == [3,11,10] --- > (invert 12 0 . tn 12 4) [1,5,6] == [7,3,2] -tni :: (Integral i, Functor f) => i -> i -> f i -> f i -tni z n = tn z n . invert z 0 - --- | Modulo multiplication. --- --- > mn 12 11 [0,1,4,9] == tni 12 0 [0,1,4,9] -mn :: (Integral i, Functor f) => i -> i -> f i -> f i -mn z n = fmap (z_mul z n) - --- | T-related sequences of /p/. --- --- > length (t_related 12 [0,3,6,9]) == 12 -t_related :: (Integral i, Functor f) => i -> f i -> [f i] -t_related z p = fmap (\n -> tn z n p) [0..11] - --- | T\/I-related sequences of /p/. --- --- > length (ti_related 12 [0,1,3]) == 24 --- > length (ti_related 12 [0,3,6,9]) == 24 --- > ti_related 12 [0] == map return [0..11] -ti_related :: (Eq (f i), Integral i, Functor f) => i -> f i -> [f i] -ti_related z p = nub (t_related z p ++ t_related z (invert z 0 p)) - --- | R\/T\/I-related sequences of /p/. --- --- > length (rti_related 12 [0,1,3]) == 48 --- > length (rti_related 12 [0,3,6,9]) == 24 -rti_related :: Integral i => i -> [i] -> [[i]] -rti_related z p = let q = ti_related z p in nub (q ++ map reverse q) - --- * Sequence operations - --- | Variant of 'tn', transpose /p/ so first element is /n/. --- --- > tn_to 12 5 [0,1,3] == [5,6,8] --- > map (tn_to 12 0) [[0,1,3],[1,3,0],[3,0,1]] -tn_to :: Integral a => a -> a -> [a] -> [a] -tn_to z n p = - case p of - [] -> [] - x:xs -> n : tn z (z_sub z n x) xs - --- | Variant of 'invert', inverse about /n/th element. --- --- > map (invert_ix 12 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] --- > map (invert_ix 12 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] -invert_ix :: Integral i => i -> Int -> [i] -> [i] -invert_ix z n p = invert z (p !! n) p - --- | The standard t-matrix of /p/. --- --- > tmatrix 12 [0,1,3] == [[0,1,3] --- > ,[11,0,2] --- > ,[9,10,0]] -tmatrix :: Integral i => i -> [i] -> [[i]] -tmatrix z p = map (\n -> tn z n p) (tn_to z 0 (invert_ix z 0 p)) diff --git a/Music/Theory/Z/Sro.hs b/Music/Theory/Z/Sro.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Sro.hs @@ -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)) diff --git a/Music/Theory/Z/Tto.hs b/Music/Theory/Z/Tto.hs new file mode 100644 --- /dev/null +++ b/Music/Theory/Z/Tto.hs @@ -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 diff --git a/Music/Theory/Z12.hs b/Music/Theory/Z12.hs deleted file mode 100644 --- a/Music/Theory/Z12.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# Language GeneralizedNewtypeDeriving #-} -module Music.Theory.Z12 where - -import Data.List {- base -} - --- | Z12 are modulo 12 integers. --- --- > map signum [-1,0::Z12,1] == [1,0,1] --- > map abs [-1,0::Z12,1] == [11,0,1] -newtype Z12 = Z12 Int deriving (Eq,Ord,Integral,Real) - --- | Cyclic 'Enum' instance for Z12. --- --- > pred (0::Z12) == 11 --- > succ (11::Z12) == 0 --- > [9::Z12 .. 3] == [9,10,11,0,1,2,3] --- > [9::Z12,11 .. 3] == [9,11,1,3] -instance Enum Z12 where - pred = subtract 1 - succ = (+) 1 - toEnum = fromIntegral - fromEnum = fromIntegral - enumFromThenTo n m o = - let m' = m + (m - n) - in if m' == o then [n,m,o] else n : enumFromThenTo m m' o - enumFromTo n m = - let n' = succ n - in if n' == m then [n,m] else n : enumFromTo n' m - --- | 'Bounded' instance for Z12. --- --- > [minBound::Z12 .. maxBound] == [0::Z12 .. 11] -instance Bounded Z12 where - minBound = Z12 0 - maxBound = Z12 11 - --- | The Z12 modulo (ie. @12@) as a 'Z12' value. This is required --- when lifting generalised @Z@ functions to 'Z12'. It is /not/ the --- same as writing @12::Z12@. --- --- > z12_modulo == Z12 12 --- > z12_modulo /= 12 --- > (12::Z12) == 0 --- > show z12_modulo == "(Z12 12)" -z12_modulo :: Z12 -z12_modulo = Z12 12 - --- | Basis for Z12 show instance. --- --- > map show [-1,0::Z12,1,z12_modulo] == ["11","0","1","(Z12 12)"] -z12_showsPrec :: Int -> Z12 -> ShowS -z12_showsPrec p (Z12 i) = - let x = showsPrec p i - in if i < 0 || i > 11 - then showString "(Z12 " . x . showString ")" - else x - -instance Show Z12 where showsPrec = z12_showsPrec - --- | Lift unary function over integers to Z12. --- --- > lift_unary_Z12 (negate) 7 == 5 -lift_unary_Z12 :: (Int -> Int) -> Z12 -> Z12 -lift_unary_Z12 f (Z12 a) = Z12 (f a `mod` 12) - --- | Lift unary function over integers to Z12. --- --- > map (lift_binary_Z12 (+) 4) [1,5,6] == [5,9,10] -lift_binary_Z12 :: (Int -> Int -> Int) -> Z12 -> Z12 -> Z12 -lift_binary_Z12 f (Z12 a) (Z12 b) = Z12 (mod (a `f` b) 12) - --- | Raise an error if the internal 'Z12' value is negative. -check_negative :: (Int -> Int) -> Z12 -> Z12 -check_negative f (Z12 n) = - if n < 0 - then error "check_negative: negative Z12" - else Z12 (f n) - -instance Num Z12 where - (+) = lift_binary_Z12 (+) - (-) = lift_binary_Z12 (-) - (*) = lift_binary_Z12 (*) - negate = lift_unary_Z12 negate - fromInteger n = Z12 (fromInteger n `mod` 12) - signum = check_negative signum - abs = check_negative abs - --- | Convert integral to 'Z12'. --- --- > map to_Z12 [-9,-3,0,13] == [3,9,0,1] -to_Z12 :: Integral i => i -> Z12 -to_Z12 = fromIntegral - --- | Convert 'Z12' to integral. -from_Z12 :: Integral i => Z12 -> i -from_Z12 = fromIntegral - --- | Z12 not in set. --- --- > complement [0,2,4,5,7,9,11] == [1,3,6,8,10] -complement :: [Z12] -> [Z12] -complement = (\\) [0 .. 11] diff --git a/Music/Theory/Z12/Castren_1994.hs b/Music/Theory/Z12/Castren_1994.hs deleted file mode 100644 --- a/Music/Theory/Z12/Castren_1994.hs +++ /dev/null @@ -1,150 +0,0 @@ --- | Marcus Castrén. /RECREL: A Similarity Measure for Set-Classes/. PhD --- thesis, Sibelius Academy, Helsinki, 1994. -module Music.Theory.Z12.Castren_1994 where - -import Data.List {- base -} -import Data.Maybe {- base -} -import Data.Ratio {- base -} - -import qualified Music.Theory.List as T -import Music.Theory.Z12 (Z12) -import qualified Music.Theory.Z12.Forte_1973 as T -import qualified Music.Theory.Z12.TTO as T - --- | Is /p/ symmetrical under inversion. --- --- > import Music.Theory.Z12.Forte_1973 --- > map inv_sym (scs_n 2) == [True,True,True,True,True,True] --- > map (fromEnum.inv_sym) (scs_n 3) == [1,0,0,0,0,1,0,0,1,1,0,1] -inv_sym :: [Z12] -> Bool -inv_sym x = x `elem` map (\i -> sort (T.tn i (T.invert 0 x))) [0..11] - --- | If /p/ is not 'inv_sym' then @(p,invert 0 p)@ else 'Nothing'. --- --- > sc_t_ti [0,2,4] == Nothing --- > sc_t_ti [0,1,3] == Just ([0,1,3],[0,2,3]) -sc_t_ti :: [Z12] -> Maybe ([Z12], [Z12]) -sc_t_ti p = - if inv_sym p - then Nothing - else Just (p,T.t_prime (T.invert 0 p)) - --- | Transpositional equivalence variant of Forte's 'sc_table'. The --- inversionally related classes are distinguished by labels @A@ and --- @B@; the class providing the /best normal order/ (Forte 1973) is --- always the @A@ class. If neither @A@ nor @B@ appears in the name of --- a set-class, it is inversionally symmetrical. --- --- > (length sc_table,length t_sc_table) == (224,352) --- > lookup "5-Z18B" t_sc_table == Just [0,2,3,6,7] -t_sc_table :: [(T.SC_Name,[Z12])] -t_sc_table = - let f x = let nm = T.sc_name x - in case sc_t_ti x of - Nothing -> [(nm,x)] - Just (p,q) -> [(nm++"A",p),(nm++"B",q)] - in concatMap f T.scs - --- | Lookup a set-class name. The input set is subject to --- 't_prime' before lookup. --- --- > t_sc_name [0,2,3,6,7] == "5-Z18B" --- > t_sc_name [0,1,4,6,7,8] == "6-Z17B" -t_sc_name :: [Z12] -> T.SC_Name -t_sc_name p = - let n = find (\(_,q) -> T.t_prime p == q) t_sc_table - in fst (fromJust n) - --- | Lookup a set-class given a set-class name. --- --- > t_sc "6-Z17A" == [0,1,2,4,7,8] -t_sc :: T.SC_Name -> [Z12] -t_sc n = snd (fromJust (find (\(m,_) -> n == m) t_sc_table)) - --- | List of set classes. -t_scs :: [[Z12]] -t_scs = map snd t_sc_table - --- | Cardinality /n/ subset of 't_scs'. --- --- > map (length . t_scs_n) [2..10] == [6,19,43,66,80,66,43,19,6] -t_scs_n :: Integral i => i -> [[Z12]] -t_scs_n n = filter ((== n) . genericLength) t_scs - --- | T-related /q/ that are subsets of /p/. --- --- > t_subsets [0,1,2,3,4] [0,1] == [[0,1],[1,2],[2,3],[3,4]] --- > t_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4]] --- > t_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6]] -t_subsets :: [Z12] -> [Z12] -> [[Z12]] -t_subsets x a = filter (`T.is_subset` x) (T.t_related a) - --- | T\/I-related /q/ that are subsets of /p/. --- --- > ti_subsets [0,1,2,3,4] [0,1] == [[0,1],[1,2],[2,3],[3,4]] --- > ti_subsets [0,1,2,3,4] [0,1,4] == [[0,1,4],[0,3,4]] --- > ti_subsets [0,2,3,6,7] [0,1,4] == [[2,3,6],[3,6,7]] -ti_subsets :: [Z12] -> [Z12] -> [[Z12]] -ti_subsets x a = filter (`T.is_subset` x) (T.ti_related a) - --- | Trivial run length encoder. --- --- > rle "abbcccdde" == [(1,'a'),(2,'b'),(3,'c'),(2,'d'),(1,'e')] -rle :: (Eq a,Integral i) => [a] -> [(i,a)] -rle = - let f x = (genericLength x,head x) - in map f . group - --- | Inverse of 'rle'. --- --- > rle_decode [(5,'a'),(4,'b')] == "aaaaabbbb" -rle_decode :: (Integral i) => [(i,a)] -> [a] -rle_decode = - let f (i,j) = genericReplicate i j - in concatMap f - --- | Length of /rle/ encoded sequence. --- --- > rle_length [(5,'a'),(4,'b')] == 9 -rle_length :: (Integral i) => [(i,a)] -> i -rle_length = sum . map fst - --- | T-equivalence /n/-class vector (subset-class vector, nCV). --- --- > t_n_class_vector 2 [0..4] == [4,3,2,1,0,0] --- > rle (t_n_class_vector 3 [0..4]) == [(1,3),(2,2),(2,1),(4,0),(1,1),(9,0)] --- > rle (t_n_class_vector 4 [0..4]) == [(1,2),(3,1),(39,0)] -t_n_class_vector :: (Num a, Integral i) => i -> [Z12] -> [a] -t_n_class_vector n x = - let a = t_scs_n n - in map (genericLength . t_subsets x) a - --- | T\/I-equivalence /n/-class vector (subset-class vector, nCV). --- --- > ti_n_class_vector 2 [0..4] == [4,3,2,1,0,0] --- > ti_n_class_vector 3 [0,1,2,3,4] == [3,4,2,0,0,1,0,0,0,0,0,0] --- > rle (ti_n_class_vector 4 [0,1,2,3,4]) == [(2,2),(1,1),(26,0)] -ti_n_class_vector :: (Num b, Integral i) => i -> [Z12] -> [b] -ti_n_class_vector n x = - let a = T.scs_n n - in map (genericLength . ti_subsets x) a - --- | 'icv' scaled by sum of /icv/. --- --- > dyad_class_percentage_vector [0,1,2,3,4] == [40,30,20,10,0,0] --- > dyad_class_percentage_vector [0,1,4,5,7] == [20,10,20,20,20,10] -dyad_class_percentage_vector :: Integral i => [Z12] -> [i] -dyad_class_percentage_vector p = - let p' = T.icv p - in map (sum p' *) p' - --- | /rel/ metric. --- --- > rel [0,1,2,3,4] [0,1,4,5,7] == 40 --- > rel [0,1,2,3,4] [0,2,4,6,8] == 60 --- > rel [0,1,4,5,7] [0,2,4,6,8] == 60 -rel :: Integral i => [Z12] -> [Z12] -> Ratio i -rel x y = - let x' = dyad_class_percentage_vector x - y' = dyad_class_percentage_vector y - in sum (map abs (zipWith (-) x' y')) % 2 diff --git a/Music/Theory/Z12/Drape_1999.hs b/Music/Theory/Z12/Drape_1999.hs deleted file mode 100644 --- a/Music/Theory/Z12/Drape_1999.hs +++ /dev/null @@ -1,342 +0,0 @@ --- | Haskell implementations of @pct@ operations. --- See . -module Music.Theory.Z12.Drape_1999 where - -import Data.Function {- base -} -import Data.List {- base -} -import Data.Maybe {- base -} - -import qualified Music.Theory.List as T -import qualified Music.Theory.Set.List as T -import Music.Theory.Z12 -import qualified Music.Theory.Z12.Forte_1973 as T -import qualified Music.Theory.Z12.Morris_1987 as T -import qualified Music.Theory.Z12.TTO as TTO -import qualified Music.Theory.Z12.SRO as SRO - --- | Cardinality filter --- --- > cf [0,3] (cg [1..4]) == [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[]] -cf :: (Integral n) => [n] -> [[a]] -> [[a]] -cf ns = filter (\p -> genericLength p `elem` ns) - --- | Combinatorial sets formed by considering each set as possible --- values for slot. --- --- > cgg [[0,1],[5,7],[3]] == [[0,5,3],[0,7,3],[1,5,3],[1,7,3]] -cgg :: [[a]] -> [[a]] -cgg l = - case l of - x:xs -> [ y:z | y <- x, z <- cgg xs ] - _ -> [[]] - --- | Combinations generator, ie. synonym for 'T.powerset'. --- --- > sort (cg [0,1,3]) == [[],[0],[0,1],[0,1,3],[0,3],[1],[1,3],[3]] -cg :: [a] -> [[a]] -cg = T.powerset - --- | Powerset filtered by cardinality. --- --- >>> cg -r3 0159 --- 015 --- 019 --- 059 --- 159 --- --- > cg_r 3 [0,1,5,9] == [[0,1,5],[0,1,9],[0,5,9],[1,5,9]] -cg_r :: (Integral n) => n -> [a] -> [[a]] -cg_r n = cf [n] . cg - --- | Cyclic interval segment. -ciseg :: [Z12] -> [Z12] -ciseg = T.int . cyc - --- | Synonynm for 'complement'. --- --- >>> cmpl 02468t --- 13579B --- --- > cmpl [0,2,4,6,8,10] == [1,3,5,7,9,11] -cmpl :: [Z12] -> [Z12] -cmpl = complement - --- | Form cycle. --- --- >>> cyc 056 --- 0560 --- --- > cyc [0,5,6] == [0,5,6,0] -cyc :: [a] -> [a] -cyc l = - case l of - [] -> [] - x:xs -> (x:xs) ++ [x] - --- | Diatonic set name. 'd' for diatonic set, 'm' for melodic minor --- set, 'o' for octotonic set. -d_nm :: (Integral a) => [a] -> Maybe Char -d_nm x = - case x of - [0,2,4,5,7,9,11] -> Just 'd' - [0,2,3,5,7,9,11] -> Just 'm' - [0,1,3,4,6,7,9,10] -> Just 'o' - _ -> Nothing - --- | Diatonic implications. -dim :: [Z12] -> [(Z12,[Z12])] -dim p = - let g (i,q) = T.is_subset p (TTO.tn i q) - f = filter g . zip [0..11] . repeat - d = [0,2,4,5,7,9,11] - m = [0,2,3,5,7,9,11] - o = [0,1,3,4,6,7,9,10] - in f d ++ f m ++ f o - --- | Variant of 'dim' that is closer to the 'pct' form. --- --- >>> dim 016 --- T1d --- T1m --- T0o --- --- > dim_nm [0,1,6] == [(1,'d'),(1,'m'),(0,'o')] -dim_nm :: [Z12] -> [(Z12,Char)] -dim_nm = - let pk f (i,j) = (i,f j) - in nubBy ((==) `on` snd) . - map (pk (fromMaybe (error "dim_mn") . d_nm)) . - dim - --- | Diatonic interval set to interval set. --- --- >>> dis 24 --- 1256 --- --- > dis [2,4] == [1,2,5,6] -dis :: (Integral t) => [Int] -> [t] -dis = - let is = [[], [], [1,2], [3,4], [5,6], [6,7], [8,9], [10,11]] - in concatMap (\j -> is !! j) - --- | Degree of intersection. --- --- >>> echo 024579e | doi 6 | sort -u --- 024579A --- 024679B --- --- > let p = [0,2,4,5,7,9,11] --- > in doi 6 p p == [[0,2,4,5,7,9,10],[0,2,4,6,7,9,11]] --- --- >>> echo 01234 | doi 2 7-35 | sort -u --- 13568AB --- --- > doi 2 (T.sc "7-35") [0,1,2,3,4] == [[1,3,5,6,8,10,11]] -doi :: Int -> [Z12] -> [Z12] -> [[Z12]] -doi n p q = - let f j = [TTO.tn j p,TTO.tni j p] - xs = concatMap f [0..11] - in T.set (filter (\x -> length (x `intersect` q) == n) xs) - --- | Forte name. -fn :: [Z12] -> String -fn = T.sc_name - --- | p `has_ess` q is true iff p can embed q in sequence. -has_ess :: [Z12] -> [Z12] -> Bool -has_ess _ [] = True -has_ess [] _ = False -has_ess (p:ps) (q:qs) = if p == q - then has_ess ps qs - else has_ess ps (q:qs) - --- | Embedded segment search. --- --- >>> echo 23a | ess 0164325 --- 2B013A9 --- 923507A --- --- > ess [2,3,10] [0,1,6,4,3,2,5] == [[9,2,3,5,0,7,10],[2,11,0,1,3,10,9]] -ess :: [Z12] -> [Z12] -> [[Z12]] -ess p = filter (`has_ess` p) . SRO.rtmi_related - --- | Can the set-class q (under prime form algorithm pf) be --- drawn from the pcset p. -has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool -has_sc_pf pf p q = - let n = length q - in q `elem` map pf (cf [n] (cg p)) - --- | Can the set-class q be drawn from the pcset p. -has_sc :: [Z12] -> [Z12] -> Bool -has_sc = has_sc_pf T.forte_prime - --- | Interval cycle filter. --- --- >>> echo 22341 | icf --- 22341 --- --- > icf [[2,2,3,4,1]] == [[2,2,3,4,1]] -icf :: (Num a,Eq a) => [[a]] -> [[a]] -icf = filter ((== 12) . sum) - --- | Interval class set to interval sets. --- --- >>> ici -c 123 --- 123 --- 129 --- 1A3 --- 1A9 --- --- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]] -ici :: (Num t) => [Int] -> [[t]] -ici xs = - let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j - ys = map is xs - in cgg ys - --- | Interval class set to interval sets, concise variant. --- --- > ici_c [1,2,3] == [[1,2,3],[1,2,9],[1,10,3],[1,10,9]] -ici_c :: [Int] -> [[Int]] -ici_c [] = [] -ici_c (x:xs) = map (x:) (ici xs) - --- | Interval-class segment. --- --- >>> icseg 013265e497t8 --- 12141655232 --- --- > icseg [0,1,3,2,6,5,11,4,9,7,10,8] == [1,2,1,4,1,6,5,5,2,3,2] -icseg :: [Z12] -> [Z12] -icseg = map T.ic . iseg - --- | Interval segment (INT). -iseg :: [Z12] -> [Z12] -iseg = T.int - --- | Imbrications. -imb :: (Integral n) => [n] -> [a] -> [[a]] -imb cs p = - let g n = (== n) . genericLength - f ps n = filter (g n) (map (genericTake n) ps) - in concatMap (f (tails p)) cs - --- | 'issb' gives the set-classes that can append to 'p' to give 'q'. --- --- >>> issb 3-7 6-32 --- 3-7 --- 3-2 --- 3-11 --- --- > issb (T.sc "3-7") (T.sc "6-32") == ["3-2","3-7","3-11"] -issb :: [Z12] -> [Z12] -> [String] -issb p q = - let k = length q - length p - f = any id . map (\x -> T.forte_prime (p ++ x) == q) . TTO.ti_related - in map T.sc_name (filter f (cf [k] T.scs)) - --- | Matrix search. --- --- >>> mxs 024579 642 | sort -u --- 6421B9 --- B97642 --- --- > T.set (mxs [0,2,4,5,7,9] [6,4,2]) == [[6,4,2,1,11,9],[11,9,7,6,4,2]] -mxs :: [Z12] -> [Z12] -> [[Z12]] -mxs p q = filter (q `isInfixOf`) (SRO.rti_related p) - --- | Normalize. --- --- >>> nrm 0123456543210 --- 0123456 --- --- > nrm [0,1,2,3,4,5,6,5,4,3,2,1,0] == [0,1,2,3,4,5,6] -nrm :: (Ord a) => [a] -> [a] -nrm = T.set - --- | Normalize, retain duplicate elements. -nrm_r :: (Ord a) => [a] -> [a] -nrm_r = sort - --- | Pitch-class invariances (called @pi@ at @pct@). --- --- >>> pi 0236 12 --- 0236 --- 6320 --- 532B --- B235 --- --- > pci [0,2,3,6] [1,2] == [[0,2,3,6],[5,3,2,11],[6,3,2,0],[11,2,3,5]] -pci :: [Z12] -> [Z12] -> [[Z12]] -pci p i = - let f q = T.set (map (q `genericIndex`) i) - in filter (\q -> f q == f p) (SRO.rti_related p) - --- | Relate sets. --- --- >>> rs 0123 641e --- T1M --- --- > import Music.Theory.Z12.Morris_1987.Parse --- > rs [0,1,2,3] [6,4,1,11] == [(rnrtnmi "T1M",[1,6,11,4]) --- > ,(rnrtnmi "T4MI",[4,11,6,1])] -rs :: [Z12] -> [Z12] -> [(T.SRO, [Z12])] -rs x y = - let xs = map (\o -> (o, o `T.sro` x)) T.sro_TnMI - q = T.set y - in filter (\(_,p) -> T.set p == q) xs - --- | Relate segments. --- --- >>> rsg 156 3BA --- T4I --- --- > rsg [1,5,6] [3,11,10] == [rnrtnmi "T4I",rnrtnmi "r1RT4MI"] --- --- >>> rsg 0123 05t3 --- T0M --- --- > rsg [0,1,2,3] [0,5,10,3] == [rnrtnmi "T0M",rnrtnmi "RT3MI"] --- --- >>> rsg 0123 4e61 --- RT1M --- --- > rsg [0,1,2,3] [4,11,6,1] == [rnrtnmi "T4MI",rnrtnmi "RT1M"] --- --- >>> echo e614 | rsg 0123 --- r3RT1M --- --- > rsg [0,1,2,3] [11,6,1,4] == [rnrtnmi "r1T4MI",rnrtnmi "r1RT1M"] --- -rsg :: [Z12] -> [Z12] -> [T.SRO] -rsg x y = map fst (filter (\(_,x') -> x' == y) (T.sros x)) - --- | Subsets. -sb :: [[Z12]] -> [[Z12]] -sb xs = - let f p = all id (map (`has_sc` p) xs) - in filter f T.scs - --- | Super set-class. --- --- >>> spsc 4-11 4-12 --- 5-26[02458] --- --- > spsc [T.sc "4-11",T.sc "4-12"] == ["5-26"] --- --- >>> spsc 3-11 3-8 --- 4-27[0258] --- 4-Z29[0137] --- --- > spsc [T.sc "3-11",T.sc "3-8"] == ["4-27","4-Z29"] --- --- >>> spsc `fl 3` --- 6-Z17[012478] --- --- > spsc (cf [3] T.scs) == ["6-Z17"] -spsc :: [[Z12]] -> [String] -spsc xs = - let f y = all (y `has_sc`) xs - g = (==) `on` length - in (map T.sc_name . head . groupBy g . filter f) T.scs diff --git a/Music/Theory/Z12/Forte_1973.hs b/Music/Theory/Z12/Forte_1973.hs deleted file mode 100644 --- a/Music/Theory/Z12/Forte_1973.hs +++ /dev/null @@ -1,554 +0,0 @@ --- | Allen Forte. /The Structure of Atonal Music/. Yale University --- Press, New Haven, 1973. -module Music.Theory.Z12.Forte_1973 where - -import Data.List {- base -} -import Data.Maybe {- base -} - -import qualified Music.Theory.Z.Forte_1973 as Z -import Music.Theory.Z12 - --- * Prime form - --- | T-related rotations of /p/. --- --- > t_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10]] -t_rotations :: [Z12] -> [[Z12]] -t_rotations = Z.t_rotations z12_modulo - --- | T\/I-related rotations of /p/. --- --- > ti_rotations [0,1,3] == [[0,1,3],[0,2,11],[0,9,10] --- > ,[0,9,11],[0,2,3],[0,1,10]] -ti_rotations :: [Z12] -> [[Z12]] -ti_rotations = Z.ti_rotations z12_modulo - --- | Forte prime form, ie. 'cmp_prime' of 'forte_cmp'. --- --- > forte_prime [0,1,3,6,8,9] == [0,1,3,6,8,9] -forte_prime :: [Z12] -> [Z12] -forte_prime = Z.forte_prime z12_modulo - --- | Transpositional equivalence prime form, ie. 't_cmp_prime' of --- 'forte_cmp'. --- --- > (forte_prime [0,2,3],t_prime [0,2,3]) == ([0,1,3],[0,2,3]) -t_prime :: [Z12] -> [Z12] -t_prime = Z.t_prime z12_modulo - --- * Set Class Table - --- | Synonym for 'String'. -type SC_Name = String - --- | The set-class table (Forte prime forms). --- --- > length sc_table == 224 -sc_table :: [(SC_Name,[Z12])] -sc_table = - [("0-1",[]) - ,("1-1",[0]) - ,("2-1",[0,1]) - ,("2-2",[0,2]) - ,("2-3",[0,3]) - ,("2-4",[0,4]) - ,("2-5",[0,5]) - ,("2-6",[0,6]) - ,("3-1",[0,1,2]) - ,("3-2",[0,1,3]) - ,("3-3",[0,1,4]) - ,("3-4",[0,1,5]) - ,("3-5",[0,1,6]) - ,("3-6",[0,2,4]) - ,("3-7",[0,2,5]) - ,("3-8",[0,2,6]) - ,("3-9",[0,2,7]) - ,("3-10",[0,3,6]) - ,("3-11",[0,3,7]) - ,("3-12",[0,4,8]) - ,("4-1",[0,1,2,3]) - ,("4-2",[0,1,2,4]) - ,("4-3",[0,1,3,4]) - ,("4-4",[0,1,2,5]) - ,("4-5",[0,1,2,6]) - ,("4-6",[0,1,2,7]) - ,("4-7",[0,1,4,5]) - ,("4-8",[0,1,5,6]) - ,("4-9",[0,1,6,7]) - ,("4-10",[0,2,3,5]) - ,("4-11",[0,1,3,5]) - ,("4-12",[0,2,3,6]) - ,("4-13",[0,1,3,6]) - ,("4-14",[0,2,3,7]) - ,("4-Z15",[0,1,4,6]) - ,("4-16",[0,1,5,7]) - ,("4-17",[0,3,4,7]) - ,("4-18",[0,1,4,7]) - ,("4-19",[0,1,4,8]) - ,("4-20",[0,1,5,8]) - ,("4-21",[0,2,4,6]) - ,("4-22",[0,2,4,7]) - ,("4-23",[0,2,5,7]) - ,("4-24",[0,2,4,8]) - ,("4-25",[0,2,6,8]) - ,("4-26",[0,3,5,8]) - ,("4-27",[0,2,5,8]) - ,("4-28",[0,3,6,9]) - ,("4-Z29",[0,1,3,7]) - ,("5-1",[0,1,2,3,4]) - ,("5-2",[0,1,2,3,5]) - ,("5-3",[0,1,2,4,5]) - ,("5-4",[0,1,2,3,6]) - ,("5-5",[0,1,2,3,7]) - ,("5-6",[0,1,2,5,6]) - ,("5-7",[0,1,2,6,7]) - ,("5-8",[0,2,3,4,6]) - ,("5-9",[0,1,2,4,6]) - ,("5-10",[0,1,3,4,6]) - ,("5-11",[0,2,3,4,7]) - ,("5-Z12",[0,1,3,5,6]) - ,("5-13",[0,1,2,4,8]) - ,("5-14",[0,1,2,5,7]) - ,("5-15",[0,1,2,6,8]) - ,("5-16",[0,1,3,4,7]) - ,("5-Z17",[0,1,3,4,8]) - ,("5-Z18",[0,1,4,5,7]) - ,("5-19",[0,1,3,6,7]) - ,("5-20",[0,1,3,7,8]) - ,("5-21",[0,1,4,5,8]) - ,("5-22",[0,1,4,7,8]) - ,("5-23",[0,2,3,5,7]) - ,("5-24",[0,1,3,5,7]) - ,("5-25",[0,2,3,5,8]) - ,("5-26",[0,2,4,5,8]) - ,("5-27",[0,1,3,5,8]) - ,("5-28",[0,2,3,6,8]) - ,("5-29",[0,1,3,6,8]) - ,("5-30",[0,1,4,6,8]) - ,("5-31",[0,1,3,6,9]) - ,("5-32",[0,1,4,6,9]) - ,("5-33",[0,2,4,6,8]) - ,("5-34",[0,2,4,6,9]) - ,("5-35",[0,2,4,7,9]) - ,("5-Z36",[0,1,2,4,7]) - ,("5-Z37",[0,3,4,5,8]) - ,("5-Z38",[0,1,2,5,8]) - ,("6-1",[0,1,2,3,4,5]) - ,("6-2",[0,1,2,3,4,6]) - ,("6-Z3",[0,1,2,3,5,6]) - ,("6-Z4",[0,1,2,4,5,6]) - ,("6-5",[0,1,2,3,6,7]) - ,("6-Z6",[0,1,2,5,6,7]) - ,("6-7",[0,1,2,6,7,8]) - ,("6-8",[0,2,3,4,5,7]) - ,("6-9",[0,1,2,3,5,7]) - ,("6-Z10",[0,1,3,4,5,7]) - ,("6-Z11",[0,1,2,4,5,7]) - ,("6-Z12",[0,1,2,4,6,7]) - ,("6-Z13",[0,1,3,4,6,7]) - ,("6-14",[0,1,3,4,5,8]) - ,("6-15",[0,1,2,4,5,8]) - ,("6-16",[0,1,4,5,6,8]) - ,("6-Z17",[0,1,2,4,7,8]) - ,("6-18",[0,1,2,5,7,8]) - ,("6-Z19",[0,1,3,4,7,8]) - ,("6-20",[0,1,4,5,8,9]) - ,("6-21",[0,2,3,4,6,8]) - ,("6-22",[0,1,2,4,6,8]) - ,("6-Z23",[0,2,3,5,6,8]) - ,("6-Z24",[0,1,3,4,6,8]) - ,("6-Z25",[0,1,3,5,6,8]) - ,("6-Z26",[0,1,3,5,7,8]) - ,("6-27",[0,1,3,4,6,9]) - ,("6-Z28",[0,1,3,5,6,9]) - ,("6-Z29",[0,1,3,6,8,9]) - ,("6-30",[0,1,3,6,7,9]) - ,("6-31",[0,1,3,5,8,9]) - ,("6-32",[0,2,4,5,7,9]) - ,("6-33",[0,2,3,5,7,9]) - ,("6-34",[0,1,3,5,7,9]) - ,("6-35",[0,2,4,6,8,10]) - ,("6-Z36",[0,1,2,3,4,7]) - ,("6-Z37",[0,1,2,3,4,8]) - ,("6-Z38",[0,1,2,3,7,8]) - ,("6-Z39",[0,2,3,4,5,8]) - ,("6-Z40",[0,1,2,3,5,8]) - ,("6-Z41",[0,1,2,3,6,8]) - ,("6-Z42",[0,1,2,3,6,9]) - ,("6-Z43",[0,1,2,5,6,8]) - ,("6-Z44",[0,1,2,5,6,9]) - ,("6-Z45",[0,2,3,4,6,9]) - ,("6-Z46",[0,1,2,4,6,9]) - ,("6-Z47",[0,1,2,4,7,9]) - ,("6-Z48",[0,1,2,5,7,9]) - ,("6-Z49",[0,1,3,4,7,9]) - ,("6-Z50",[0,1,4,6,7,9]) - ,("7-1",[0,1,2,3,4,5,6]) - ,("7-2",[0,1,2,3,4,5,7]) - ,("7-3",[0,1,2,3,4,5,8]) - ,("7-4",[0,1,2,3,4,6,7]) - ,("7-5",[0,1,2,3,5,6,7]) - ,("7-6",[0,1,2,3,4,7,8]) - ,("7-7",[0,1,2,3,6,7,8]) - ,("7-8",[0,2,3,4,5,6,8]) - ,("7-9",[0,1,2,3,4,6,8]) - ,("7-10",[0,1,2,3,4,6,9]) - ,("7-11",[0,1,3,4,5,6,8]) - ,("7-Z12",[0,1,2,3,4,7,9]) - ,("7-13",[0,1,2,4,5,6,8]) - ,("7-14",[0,1,2,3,5,7,8]) - ,("7-15",[0,1,2,4,6,7,8]) - ,("7-16",[0,1,2,3,5,6,9]) - ,("7-Z17",[0,1,2,4,5,6,9]) - ,("7-Z18",[0,1,2,3,5,8,9]) - ,("7-19",[0,1,2,3,6,7,9]) - ,("7-20",[0,1,2,4,7,8,9]) - ,("7-21",[0,1,2,4,5,8,9]) - ,("7-22",[0,1,2,5,6,8,9]) - ,("7-23",[0,2,3,4,5,7,9]) - ,("7-24",[0,1,2,3,5,7,9]) - ,("7-25",[0,2,3,4,6,7,9]) - ,("7-26",[0,1,3,4,5,7,9]) - ,("7-27",[0,1,2,4,5,7,9]) - ,("7-28",[0,1,3,5,6,7,9]) - ,("7-29",[0,1,2,4,6,7,9]) - ,("7-30",[0,1,2,4,6,8,9]) - ,("7-31",[0,1,3,4,6,7,9]) - ,("7-32",[0,1,3,4,6,8,9]) - ,("7-33",[0,1,2,4,6,8,10]) - ,("7-34",[0,1,3,4,6,8,10]) - ,("7-35",[0,1,3,5,6,8,10]) - ,("7-Z36",[0,1,2,3,5,6,8]) - ,("7-Z37",[0,1,3,4,5,7,8]) - ,("7-Z38",[0,1,2,4,5,7,8]) - ,("8-1",[0,1,2,3,4,5,6,7]) - ,("8-2",[0,1,2,3,4,5,6,8]) - ,("8-3",[0,1,2,3,4,5,6,9]) - ,("8-4",[0,1,2,3,4,5,7,8]) - ,("8-5",[0,1,2,3,4,6,7,8]) - ,("8-6",[0,1,2,3,5,6,7,8]) - ,("8-7",[0,1,2,3,4,5,8,9]) - ,("8-8",[0,1,2,3,4,7,8,9]) - ,("8-9",[0,1,2,3,6,7,8,9]) - ,("8-10",[0,2,3,4,5,6,7,9]) - ,("8-11",[0,1,2,3,4,5,7,9]) - ,("8-12",[0,1,3,4,5,6,7,9]) - ,("8-13",[0,1,2,3,4,6,7,9]) - ,("8-14",[0,1,2,4,5,6,7,9]) - ,("8-Z15",[0,1,2,3,4,6,8,9]) - ,("8-16",[0,1,2,3,5,7,8,9]) - ,("8-17",[0,1,3,4,5,6,8,9]) - ,("8-18",[0,1,2,3,5,6,8,9]) - ,("8-19",[0,1,2,4,5,6,8,9]) - ,("8-20",[0,1,2,4,5,7,8,9]) - ,("8-21",[0,1,2,3,4,6,8,10]) - ,("8-22",[0,1,2,3,5,6,8,10]) - ,("8-23",[0,1,2,3,5,7,8,10]) - ,("8-24",[0,1,2,4,5,6,8,10]) - ,("8-25",[0,1,2,4,6,7,8,10]) - ,("8-26",[0,1,2,4,5,7,9,10]) - ,("8-27",[0,1,2,4,5,7,8,10]) - ,("8-28",[0,1,3,4,6,7,9,10]) - ,("8-Z29",[0,1,2,3,5,6,7,9]) - ,("9-1",[0,1,2,3,4,5,6,7,8]) - ,("9-2",[0,1,2,3,4,5,6,7,9]) - ,("9-3",[0,1,2,3,4,5,6,8,9]) - ,("9-4",[0,1,2,3,4,5,7,8,9]) - ,("9-5",[0,1,2,3,4,6,7,8,9]) - ,("9-6",[0,1,2,3,4,5,6,8,10]) - ,("9-7",[0,1,2,3,4,5,7,8,10]) - ,("9-8",[0,1,2,3,4,6,7,8,10]) - ,("9-9",[0,1,2,3,5,6,7,8,10]) - ,("9-10",[0,1,2,3,4,6,7,9,10]) - ,("9-11",[0,1,2,3,5,6,7,9,10]) - ,("9-12",[0,1,2,4,5,6,8,9,10]) - ,("10-1",[0,1,2,3,4,5,6,7,8,9]) - ,("10-2",[0,1,2,3,4,5,6,7,8,10]) - ,("10-3",[0,1,2,3,4,5,6,7,9,10]) - ,("10-4",[0,1,2,3,4,5,6,8,9,10]) - ,("10-5",[0,1,2,3,4,5,7,8,9,10]) - ,("10-6",[0,1,2,3,4,6,7,8,9,10]) - ,("11-1",[0,1,2,3,4,5,6,7,8,9,10]) - ,("12-1",[0,1,2,3,4,5,6,7,8,9,10,11])] - --- | Lookup a set-class name. The input set is subject to --- 'forte_prime' before lookup. --- --- > sc_name [0,2,3,6,7] == "5-Z18" --- > sc_name [0,1,4,6,7,8] == "6-Z17" -sc_name :: [Z12] -> SC_Name -sc_name p = - let n = find (\(_,q) -> forte_prime p == q) sc_table - in fst (fromMaybe (error "sc_name") n) - --- | Lookup a set-class given a set-class name. --- --- > sc "6-Z17" == [0,1,2,4,7,8] -sc :: SC_Name -> [Z12] -sc n = snd (fromMaybe (error "sc") (find (\(m,_) -> n == m) sc_table)) - -{- | List of set classes (the set class universe). - -> let r = [("0-1",[0,0,0,0,0,0]) -> ,("1-1",[0,0,0,0,0,0]) -> ,("2-1",[1,0,0,0,0,0]) -> ,("2-2",[0,1,0,0,0,0]) -> ,("2-3",[0,0,1,0,0,0]) -> ,("2-4",[0,0,0,1,0,0]) -> ,("2-5",[0,0,0,0,1,0]) -> ,("2-6",[0,0,0,0,0,1]) -> ,("3-1",[2,1,0,0,0,0]) -> ,("3-2",[1,1,1,0,0,0]) -> ,("3-3",[1,0,1,1,0,0]) -> ,("3-4",[1,0,0,1,1,0]) -> ,("3-5",[1,0,0,0,1,1]) -> ,("3-6",[0,2,0,1,0,0]) -> ,("3-7",[0,1,1,0,1,0]) -> ,("3-8",[0,1,0,1,0,1]) -> ,("3-9",[0,1,0,0,2,0]) -> ,("3-10",[0,0,2,0,0,1]) -> ,("3-11",[0,0,1,1,1,0]) -> ,("3-12",[0,0,0,3,0,0]) -> ,("4-1",[3,2,1,0,0,0]) -> ,("4-2",[2,2,1,1,0,0]) -> ,("4-3",[2,1,2,1,0,0]) -> ,("4-4",[2,1,1,1,1,0]) -> ,("4-5",[2,1,0,1,1,1]) -> ,("4-6",[2,1,0,0,2,1]) -> ,("4-7",[2,0,1,2,1,0]) -> ,("4-8",[2,0,0,1,2,1]) -> ,("4-9",[2,0,0,0,2,2]) -> ,("4-10",[1,2,2,0,1,0]) -> ,("4-11",[1,2,1,1,1,0]) -> ,("4-12",[1,1,2,1,0,1]) -> ,("4-13",[1,1,2,0,1,1]) -> ,("4-14",[1,1,1,1,2,0]) -> ,("4-Z15",[1,1,1,1,1,1]) -> ,("4-16",[1,1,0,1,2,1]) -> ,("4-17",[1,0,2,2,1,0]) -> ,("4-18",[1,0,2,1,1,1]) -> ,("4-19",[1,0,1,3,1,0]) -> ,("4-20",[1,0,1,2,2,0]) -> ,("4-21",[0,3,0,2,0,1]) -> ,("4-22",[0,2,1,1,2,0]) -> ,("4-23",[0,2,1,0,3,0]) -> ,("4-24",[0,2,0,3,0,1]) -> ,("4-25",[0,2,0,2,0,2]) -> ,("4-26",[0,1,2,1,2,0]) -> ,("4-27",[0,1,2,1,1,1]) -> ,("4-28",[0,0,4,0,0,2]) -> ,("4-Z29",[1,1,1,1,1,1]) -> ,("5-1",[4,3,2,1,0,0]) -> ,("5-2",[3,3,2,1,1,0]) -> ,("5-3",[3,2,2,2,1,0]) -> ,("5-4",[3,2,2,1,1,1]) -> ,("5-5",[3,2,1,1,2,1]) -> ,("5-6",[3,1,1,2,2,1]) -> ,("5-7",[3,1,0,1,3,2]) -> ,("5-8",[2,3,2,2,0,1]) -> ,("5-9",[2,3,1,2,1,1]) -> ,("5-10",[2,2,3,1,1,1]) -> ,("5-11",[2,2,2,2,2,0]) -> ,("5-Z12",[2,2,2,1,2,1]) -> ,("5-13",[2,2,1,3,1,1]) -> ,("5-14",[2,2,1,1,3,1]) -> ,("5-15",[2,2,0,2,2,2]) -> ,("5-16",[2,1,3,2,1,1]) -> ,("5-Z17",[2,1,2,3,2,0]) -> ,("5-Z18",[2,1,2,2,2,1]) -> ,("5-19",[2,1,2,1,2,2]) -> ,("5-20",[2,1,1,2,3,1]) -> ,("5-21",[2,0,2,4,2,0]) -> ,("5-22",[2,0,2,3,2,1]) -> ,("5-23",[1,3,2,1,3,0]) -> ,("5-24",[1,3,1,2,2,1]) -> ,("5-25",[1,2,3,1,2,1]) -> ,("5-26",[1,2,2,3,1,1]) -> ,("5-27",[1,2,2,2,3,0]) -> ,("5-28",[1,2,2,2,1,2]) -> ,("5-29",[1,2,2,1,3,1]) -> ,("5-30",[1,2,1,3,2,1]) -> ,("5-31",[1,1,4,1,1,2]) -> ,("5-32",[1,1,3,2,2,1]) -> ,("5-33",[0,4,0,4,0,2]) -> ,("5-34",[0,3,2,2,2,1]) -> ,("5-35",[0,3,2,1,4,0]) -> ,("5-Z36",[2,2,2,1,2,1]) -> ,("5-Z37",[2,1,2,3,2,0]) -> ,("5-Z38",[2,1,2,2,2,1]) -> ,("6-1",[5,4,3,2,1,0]) -> ,("6-2",[4,4,3,2,1,1]) -> ,("6-Z3",[4,3,3,2,2,1]) -> ,("6-Z4",[4,3,2,3,2,1]) -> ,("6-5",[4,2,2,2,3,2]) -> ,("6-Z6",[4,2,1,2,4,2]) -> ,("6-7",[4,2,0,2,4,3]) -> ,("6-8",[3,4,3,2,3,0]) -> ,("6-9",[3,4,2,2,3,1]) -> ,("6-Z10",[3,3,3,3,2,1]) -> ,("6-Z11",[3,3,3,2,3,1]) -> ,("6-Z12",[3,3,2,2,3,2]) -> ,("6-Z13",[3,2,4,2,2,2]) -> ,("6-14",[3,2,3,4,3,0]) -> ,("6-15",[3,2,3,4,2,1]) -> ,("6-16",[3,2,2,4,3,1]) -> ,("6-Z17",[3,2,2,3,3,2]) -> ,("6-18",[3,2,2,2,4,2]) -> ,("6-Z19",[3,1,3,4,3,1]) -> ,("6-20",[3,0,3,6,3,0]) -> ,("6-21",[2,4,2,4,1,2]) -> ,("6-22",[2,4,1,4,2,2]) -> ,("6-Z23",[2,3,4,2,2,2]) -> ,("6-Z24",[2,3,3,3,3,1]) -> ,("6-Z25",[2,3,3,2,4,1]) -> ,("6-Z26",[2,3,2,3,4,1]) -> ,("6-27",[2,2,5,2,2,2]) -> ,("6-Z28",[2,2,4,3,2,2]) -> ,("6-Z29",[2,2,4,2,3,2]) -> ,("6-30",[2,2,4,2,2,3]) -> ,("6-31",[2,2,3,4,3,1]) -> ,("6-32",[1,4,3,2,5,0]) -> ,("6-33",[1,4,3,2,4,1]) -> ,("6-34",[1,4,2,4,2,2]) -> ,("6-35",[0,6,0,6,0,3]) -> ,("6-Z36",[4,3,3,2,2,1]) -> ,("6-Z37",[4,3,2,3,2,1]) -> ,("6-Z38",[4,2,1,2,4,2]) -> ,("6-Z39",[3,3,3,3,2,1]) -> ,("6-Z40",[3,3,3,2,3,1]) -> ,("6-Z41",[3,3,2,2,3,2]) -> ,("6-Z42",[3,2,4,2,2,2]) -> ,("6-Z43",[3,2,2,3,3,2]) -> ,("6-Z44",[3,1,3,4,3,1]) -> ,("6-Z45",[2,3,4,2,2,2]) -> ,("6-Z46",[2,3,3,3,3,1]) -> ,("6-Z47",[2,3,3,2,4,1]) -> ,("6-Z48",[2,3,2,3,4,1]) -> ,("6-Z49",[2,2,4,3,2,2]) -> ,("6-Z50",[2,2,4,2,3,2]) -> ,("7-1",[6,5,4,3,2,1]) -> ,("7-2",[5,5,4,3,3,1]) -> ,("7-3",[5,4,4,4,3,1]) -> ,("7-4",[5,4,4,3,3,2]) -> ,("7-5",[5,4,3,3,4,2]) -> ,("7-6",[5,3,3,4,4,2]) -> ,("7-7",[5,3,2,3,5,3]) -> ,("7-8",[4,5,4,4,2,2]) -> ,("7-9",[4,5,3,4,3,2]) -> ,("7-10",[4,4,5,3,3,2]) -> ,("7-11",[4,4,4,4,4,1]) -> ,("7-Z12",[4,4,4,3,4,2]) -> ,("7-13",[4,4,3,5,3,2]) -> ,("7-14",[4,4,3,3,5,2]) -> ,("7-15",[4,4,2,4,4,3]) -> ,("7-16",[4,3,5,4,3,2]) -> ,("7-Z17",[4,3,4,5,4,1]) -> ,("7-Z18",[4,3,4,4,4,2]) -> ,("7-19",[4,3,4,3,4,3]) -> ,("7-20",[4,3,3,4,5,2]) -> ,("7-21",[4,2,4,6,4,1]) -> ,("7-22",[4,2,4,5,4,2]) -> ,("7-23",[3,5,4,3,5,1]) -> ,("7-24",[3,5,3,4,4,2]) -> ,("7-25",[3,4,5,3,4,2]) -> ,("7-26",[3,4,4,5,3,2]) -> ,("7-27",[3,4,4,4,5,1]) -> ,("7-28",[3,4,4,4,3,3]) -> ,("7-29",[3,4,4,3,5,2]) -> ,("7-30",[3,4,3,5,4,2]) -> ,("7-31",[3,3,6,3,3,3]) -> ,("7-32",[3,3,5,4,4,2]) -> ,("7-33",[2,6,2,6,2,3]) -> ,("7-34",[2,5,4,4,4,2]) -> ,("7-35",[2,5,4,3,6,1]) -> ,("7-Z36",[4,4,4,3,4,2]) -> ,("7-Z37",[4,3,4,5,4,1]) -> ,("7-Z38",[4,3,4,4,4,2]) -> ,("8-1",[7,6,5,4,4,2]) -> ,("8-2",[6,6,5,5,4,2]) -> ,("8-3",[6,5,6,5,4,2]) -> ,("8-4",[6,5,5,5,5,2]) -> ,("8-5",[6,5,4,5,5,3]) -> ,("8-6",[6,5,4,4,6,3]) -> ,("8-7",[6,4,5,6,5,2]) -> ,("8-8",[6,4,4,5,6,3]) -> ,("8-9",[6,4,4,4,6,4]) -> ,("8-10",[5,6,6,4,5,2]) -> ,("8-11",[5,6,5,5,5,2]) -> ,("8-12",[5,5,6,5,4,3]) -> ,("8-13",[5,5,6,4,5,3]) -> ,("8-14",[5,5,5,5,6,2]) -> ,("8-Z15",[5,5,5,5,5,3]) -> ,("8-16",[5,5,4,5,6,3]) -> ,("8-17",[5,4,6,6,5,2]) -> ,("8-18",[5,4,6,5,5,3]) -> ,("8-19",[5,4,5,7,5,2]) -> ,("8-20",[5,4,5,6,6,2]) -> ,("8-21",[4,7,4,6,4,3]) -> ,("8-22",[4,6,5,5,6,2]) -> ,("8-23",[4,6,5,4,7,2]) -> ,("8-24",[4,6,4,7,4,3]) -> ,("8-25",[4,6,4,6,4,4]) -> ,("8-26",[4,5,6,5,6,2]) -> ,("8-27",[4,5,6,5,5,3]) -> ,("8-28",[4,4,8,4,4,4]) -> ,("8-Z29",[5,5,5,5,5,3]) -> ,("9-1",[8,7,6,6,6,3]) -> ,("9-2",[7,7,7,6,6,3]) -> ,("9-3",[7,6,7,7,6,3]) -> ,("9-4",[7,6,6,7,7,3]) -> ,("9-5",[7,6,6,6,7,4]) -> ,("9-6",[6,8,6,7,6,3]) -> ,("9-7",[6,7,7,6,7,3]) -> ,("9-8",[6,7,6,7,6,4]) -> ,("9-9",[6,7,6,6,8,3]) -> ,("9-10",[6,6,8,6,6,4]) -> ,("9-11",[6,6,7,7,7,3]) -> ,("9-12",[6,6,6,9,6,3]) -> ,("10-1",[9,8,8,8,8,4]) -> ,("10-2",[8,9,8,8,8,4]) -> ,("10-3",[8,8,9,8,8,4]) -> ,("10-4",[8,8,8,9,8,4]) -> ,("10-5",[8,8,8,8,9,4]) -> ,("10-6",[8,8,8,8,8,5]) -> ,("11-1",[10,10,10,10,10,5]) -> ,("12-1",[12,12,12,12,12,6])] -> in let icvs = map icv scs in zip (map sc_name scs) icvs == r - --} -scs :: [[Z12]] -scs = map snd sc_table - --- | Cardinality /n/ subset of 'scs'. --- --- > map (length . scs_n) [1..11] == [1,6,12,29,38,50,38,29,12,6,1] -scs_n :: Integral i => i -> [[Z12]] -scs_n n = filter ((== n) . genericLength) scs - --- * BIP Metric - --- | Basic interval pattern, see Allen Forte \"The Basic Interval Patterns\" --- /JMT/ 17/2 (1973):234-272 --- --- >>> bip 0t95728e3416 --- 11223344556 --- --- > bip [0,10,9,5,7,2,8,11,3,4,1,6] == [1,1,2,2,3,3,4,4,5,5,6] --- > bip (pco "0t95728e3416") == [1,1,2,2,3,3,4,4,5,5,6] -bip :: [Z12] -> [Z12] -bip = Z.bip z12_modulo - --- * ICV Metric - --- | Interval class of Z12 interval /i/. --- --- > map ic [5,6,7] == [5,6,5] --- > map ic [-13,-1,0,1,13] == [1,1,0,1,1] -ic :: Z12 -> Z12 -ic = Z.ic z12_modulo - --- | Forte notation for interval class vector. --- --- > icv [0,1,2,4,7,8] == [3,2,2,3,3,2] -icv :: Integral i => [Z12] -> [i] -icv = Z.icv z12_modulo diff --git a/Music/Theory/Z12/Lewin_1980.hs b/Music/Theory/Z12/Lewin_1980.hs deleted file mode 100644 --- a/Music/Theory/Z12/Lewin_1980.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | David Lewin. \"A Response to a Response: On PC Set --- Relatedness\". /Perspectives of New Music/, 18(1-2):498-502, 1980. -module Music.Theory.Z12.Lewin_1980 where - -import Data.List -import Music.Theory.Z12 -import qualified Music.Theory.Z12.Castren_1994 as C - --- | REL function with given /ncv/ function (see 't_rel' and 'ti_rel'). -rel :: Floating n => (Int -> [a] -> [n]) -> [a] -> [a] -> n -rel ncv x y = - let n = min (genericLength x) (genericLength y) - p = map (`ncv` x) [2..n] - q = map (`ncv` y) [2..n] - f = zipWith (\i j -> sqrt (i * j)) - pt = sum (map sum p) - qt = sum (map sum q) - in sum (map sum (zipWith f p q)) / sqrt (pt * qt) - --- | T-equivalence REL function. --- --- Kuusi 2001, 7.5.2 --- --- > let (~=) p q = abs (p - q) < 1e-2 --- > t_rel [0,1,2,3,4] [0,2,3,6,7] ~= 0.44 --- > t_rel [0,1,2,3,4] [0,2,4,6,8] ~= 0.28 --- > t_rel [0,2,3,6,7] [0,2,4,6,8] ~= 0.31 -t_rel :: Floating n => [Z12] -> [Z12] -> n -t_rel = rel C.t_n_class_vector - --- | T/I-equivalence REL function. --- --- Buchler 1998, Fig. 3.38 --- --- > let (~=) p q = abs (p - q) < 1e-3 --- > let a = [0,2,3,5,7]::[Z12] --- > let b = [0,2,3,4,5,8]::[Z12] --- > let g = [0,1,2,3,5,6,8,10]::[Z12] --- > let j = [0,2,3,4,5,6,8]::[Z12] --- > ti_rel a b ~= 0.593 --- > ti_rel a g ~= 0.648 --- > ti_rel a j ~= 0.509 --- > ti_rel b g ~= 0.712 --- > ti_rel b j ~= 0.892 --- > ti_rel g j ~= 0.707 -ti_rel :: Floating n => [Z12] -> [Z12] -> n -ti_rel = rel C.ti_n_class_vector diff --git a/Music/Theory/Z12/Literature.hs b/Music/Theory/Z12/Literature.hs deleted file mode 100644 --- a/Music/Theory/Z12/Literature.hs +++ /dev/null @@ -1,48 +0,0 @@ --- | Z12 set class database. -module Music.Theory.Z12.Literature where - --- | Set class database with descriptors for historically and --- theoretically significant set classes, indexed by Forte name. --- --- > lookup "6-Z17" sc_db == Just "All-Trichord Hexachord" --- > lookup "7-35" sc_db == Just "diatonic collection (d)" -sc_db :: [(String,String)] -sc_db = - [("4-Z15","All-Interval Tetrachord (see also 4-Z29)") - ,("4-Z29","All-Interval Tetrachord (see also 4-Z15)") - ,("6-Z17","All-Trichord Hexachord") - ,("8-Z15","All-Tetrachord Octochord (see also 8-Z29)") - ,("8-Z29","All-Tetrachord Octochord (see also 8-Z15)") - ,("6-1","A-Type All-Combinatorial Hexachord") - ,("6-8","B-Type All-Combinatorial Hexachord") - ,("6-32","C-Type All-Combinatorial Hexachord") - ,("6-7","D-Type All-Combinatorial Hexachord") - ,("6-20","E-Type All-Combinatorial Hexachord") - ,("6-35","F-Type All-Combinatorial Hexachord") - ,("7-35","diatonic collection (d)") - ,("7-34","ascending melodic minor collection") - ,("8-28","octotonic collection (Messiaen Mode II)") - ,("6-35","wholetone collection") - ,("3-10","diminished triad") - ,("3-11","major/minor triad") - ,("3-12","augmented triad") - ,("4-19","minor major-seventh chord") - ,("4-20","major-seventh chord") - ,("4-25","french augmented sixth chord") - ,("4-28","dimished-seventh chord") - ,("4-26","minor-seventh chord") - ,("4-27","half-dimished seventh(P)/dominant-seventh(I) chord") - ,("6-30","Petrushka Chord {0476a1},3-11 at T6") - ,("6-34","Mystic Chord {06a492}") - ,("6-Z44","Schoenberg Signature Set,3-3 at T5 or T7") - ,("6-Z19","complement of 6-Z44,3-11 at T1 or TB") - ,("9-12","Messiaen Mode III (nontonic collection)") - ,("8-9","Messian Mode IV") - ,("7-31","The only seven-element subset of 8-28. ") - ,("5-31","The only five-element superset of 4-28.") - ,("5-33","The only five-element subset of 6-35.") - ,("7-33","The only seven-element superset of 6-35.") - ,("5-21","The only five-element subset of 6-20.") - ,("7-21","The only seven-element superset of 6-20.") - ,("5-25","The only five-element subset of both 7-35 and 8-28.") - ,("6-14","Any non-intersecting union of 3-6 and 3-12.") ] diff --git a/Music/Theory/Z12/Morris_1974.hs b/Music/Theory/Z12/Morris_1974.hs deleted file mode 100644 --- a/Music/Theory/Z12/Morris_1974.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Robert Morris and D. Starr. \"The Structure of All-Interval Series\". --- /Journal of Music Theory/, 18:364-389, 1974. -module Music.Theory.Z12.Morris_1974 where - -import Control.Monad.Logic {- logict -} - --- | 'msum' '.' 'map' 'return'. --- --- > observeAll (fromList [1..7]) == [1..7] -fromList :: MonadPlus m => [a] -> m a -fromList = msum . map return - --- | 'MonadPlus' all-interval series. --- --- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` observeAll (all_interval_m 12) --- > length (observeAll (all_interval_m 12)) == 3856 --- > map (length . observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288] -all_interval_m :: MonadPlus m => Int -> m [Int] -all_interval_m n = - let rec p q = - if length p == n - then return (reverse p) - else do i <- fromList [1 .. n - 1] - guard (i `notElem` p) - let j:_ = p - m = abs ((i - j) `mod` n) - guard (m `notElem` q) - rec (i:p) (m:q) - in rec [0] [] - --- | 'observeAll' of 'all_interval_m'. --- --- > let r = [[0,1,5,2,4,3],[0,2,1,4,5,3],[0,4,5,2,1,3],[0,5,1,4,2,3]] --- > in all_interval 6 == r -all_interval :: Int -> [[Int]] -all_interval = observeAll . all_interval_m diff --git a/Music/Theory/Z12/Morris_1987.hs b/Music/Theory/Z12/Morris_1987.hs deleted file mode 100644 --- a/Music/Theory/Z12/Morris_1987.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Robert Morris. /Composition with Pitch-Classes: A Theory of --- Compositional Design/. Yale University Press, New Haven, 1987. -module Music.Theory.Z12.Morris_1987 where - -import Data.List -import Music.Theory.List -import Music.Theory.Z12 -import Music.Theory.Z12.SRO - --- | @INT@ operator. --- --- > int [0,1,3,6,10] == [1,2,3,4] -int :: [Z12] -> [Z12] -int = d_dx - --- * Serial operations - --- | Serial Operator,of the form rRTMI. -data SRO = SRO Z12 Bool Z12 Bool Bool - deriving (Eq,Show) - --- | Serial operation. --- --- >>> sro T4 156 --- 59A --- --- > sro (rnrtnmi "T4") (pco "156") == [5,9,10] --- --- >>> echo 024579 | sro RT4I --- 79B024 --- --- > sro (SRO 0 True 4 False True) [0,2,4,5,7,9] == [7,9,11,0,2,4] --- --- >>> sro T4I 156 --- 3BA --- --- > sro (rnrtnmi "T4I") (pco "156") == [3,11,10] --- > sro (SRO 0 False 4 False True) [1,5,6] == [3,11,10] --- --- >>> echo 156 | sro T4 | sro T0I --- 732 --- --- > (sro (rnrtnmi "T0I") . sro (rnrtnmi "T4")) (pco "156") == [7,3,2] --- --- >>> echo 024579 | sro RT4I --- 79B024 --- --- > sro (rnrtnmi "RT4I") (pco "024579") == [7,9,11,0,2,4] --- --- > sro (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4] --- > sro (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4] -sro :: SRO -> [Z12] -> [Z12] -sro (SRO r r' t m i) x = - let x1 = if i then invert 0 x else x - x2 = if m then m5 x1 else x1 - x3 = tn t x2 - x4 = if r' then reverse x3 else x3 - in genericRotate_left r x4 - --- | The total set of serial operations. -sros :: [Z12] -> [(SRO,[Z12])] -sros x = [let o = (SRO r r' t m i) in (o,sro o x) | - r <- [0 .. genericLength x - 1], - r' <- [False,True], - t <- [0 .. 11], - m <- [False,True], - i <- [False,True]] - --- | The set of transposition 'SRO's. -sro_Tn ::[SRO] -sro_Tn = [SRO 0 False n False False | n <- [0..11]] - --- | The set of transposition and inversion 'SRO's. -sro_TnI ::[SRO] -sro_TnI = [SRO 0 False n False i | - n <- [0..11], - i <- [False,True]] - --- | The set of retrograde and transposition and inversion 'SRO's. -sro_RTnI ::[SRO] -sro_RTnI = [SRO 0 r n False i | - r <- [True,False], - n <- [0..11], - i <- [False,True]] - --- | The set of transposition,@M5@ and inversion 'SRO's. -sro_TnMI ::[SRO] -sro_TnMI = [SRO 0 False n m i | - n <- [0..11], - m <- [True,False], - i <- [True,False]] - --- | The set of retrograde,transposition,@M5@ and inversion 'SRO's. -sro_RTnMI ::[SRO] -sro_RTnMI = [SRO 0 r n m i | - r <- [True,False], - n <- [0..11], - m <- [True,False], - i <- [True,False]] diff --git a/Music/Theory/Z12/Morris_1987/Parse.hs b/Music/Theory/Z12/Morris_1987/Parse.hs deleted file mode 100644 --- a/Music/Theory/Z12/Morris_1987/Parse.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | Parsers for pitch class sets and sequences, and for 'SRO's. -module Music.Theory.Z12.Morris_1987.Parse (rnrtnmi,pco) where - -import Control.Monad {- base -} -import Data.Char {- base -} -import Text.ParserCombinators.Parsec {- parsec -} - -import Music.Theory.Z12 -import Music.Theory.Z12.Morris_1987 - --- | A 'Char' parser. -type P a = GenParser Char () a - --- | Boolean 'P' for given 'Char'. -is_char :: Char -> P Bool -is_char c = - let f '_' = False - f _ = True - in liftM f (option '_' (char c)) - --- | Parse 'Int'. -get_int :: P Z12 -get_int = liftM (fromInteger . read) (many1 digit) - --- | Parse a Morris format serial operator descriptor. --- --- > rnrtnmi "r2RT3MI" == SRO 2 True 3 True True -rnrtnmi :: String -> SRO -rnrtnmi s = - let p = do r <- rot - r' <- is_char 'R' - _ <- char 'T' - t <- get_int - m <- is_char 'M' - i <- is_char 'I' - eof - return (SRO r r' t m i) - rot = option 0 (char 'r' >> get_int) - in either - (\e -> error ("rnRTnMI parse failed\n" ++ show e)) - id - (parse p "" s) - --- | Parse a /pitch class object/ string. Each 'Char' is either a --- number, a space which is ignored, or a letter name for the numbers --- 10 ('t' or 'a' or 'A') or 11 ('e' or 'B' or 'b'). --- --- > pco "13te" == [1,3,10,11] --- > pco "13te" == pco "13ab" -pco :: String -> [Z12] -pco s = - let s' = dropWhile isSpace s - s'' = takeWhile (`elem` "0123456789taAebB") s' - f c | c `elem` "taA" = 10 - | c `elem` "ebB" = 11 - | otherwise = fromInteger (read [c]) - in map f s'' diff --git a/Music/Theory/Z12/Rahn_1980.hs b/Music/Theory/Z12/Rahn_1980.hs deleted file mode 100644 --- a/Music/Theory/Z12/Rahn_1980.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | John Rahn. /Basic Atonal Theory/. Longman, New York, 1980. -module Music.Theory.Z12.Rahn_1980 where - -import Music.Theory.Z12 -import qualified Music.Theory.Z.Forte_1973 as Z - --- | Rahn prime form (comparison is rightmost inwards). --- --- > rahn_cmp [0,1,3,6,8,9] [0,2,3,6,7,9] == GT -rahn_cmp :: Ord a => [a] -> [a] -> Ordering -rahn_cmp p q = compare (reverse p) (reverse q) - --- | Rahn prime form, ie. 'ti_cmp_prime' of 'rahn_cmp'. --- --- > rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] --- --- > import Music.Theory.Z12.Forte_1973 --- --- > let s = [[0,1,3,7,8] --- > ,[0,1,3,6,8,9],[0,1,3,5,8,9] --- > ,[0,1,2,4,7,8,9] --- > ,[0,1,2,4,5,7,9,10]] --- > in all (\p -> forte_prime p /= rahn_prime p) s == True -rahn_prime :: [Z12] -> [Z12] -rahn_prime = Z.ti_cmp_prime z12_modulo rahn_cmp diff --git a/Music/Theory/Z12/Read_1978.hs b/Music/Theory/Z12/Read_1978.hs deleted file mode 100644 --- a/Music/Theory/Z12/Read_1978.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Ronald C. Read. \"Every one a winner or how to avoid isomorphism --- search when cataloguing combinatorial configurations.\" /Annals of --- Discrete Mathematics/ 2:107–20, 1978. -module Music.Theory.Z12.Read_1978 where - -import Music.Theory.Z12 {- hmt -} -import qualified Music.Theory.Z.Read_1978 as Z {- hmt -} - -type Code = Z.Code - --- | Encoder for 'encode_prime'. --- --- > encode [0,1,3,6,8,9] == 843 -encode :: [Z12] -> Code -encode = Z.encode - --- | Decoder for 'encode_prime'. --- --- > decode 843 == [0,1,3,6,8,9] -decode :: Code -> [Z12] -decode = Z.decode 12 - --- | Binary encoding prime form algorithm, equalivalent to Rahn. --- --- > encode_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] --- > Music.Theory.Z12.Rahn_1980.rahn_prime [0,1,3,6,8,9] == [0,2,3,6,7,9] -encode_prime :: [Z12] -> [Z12] -encode_prime = Z.encode_prime z12_modulo diff --git a/Music/Theory/Z12/SRO.hs b/Music/Theory/Z12/SRO.hs deleted file mode 100644 --- a/Music/Theory/Z12/SRO.hs +++ /dev/null @@ -1,96 +0,0 @@ --- | Serial (ordered) pitch-class operations on 'Z12'. -module Music.Theory.Z12.SRO where - -import Data.List -import qualified Music.Theory.List as T -import qualified Music.Theory.Z.SRO as Z -import Music.Theory.Z12 - --- | Transpose /p/ by /n/. --- --- > tn 4 [1,5,6] == [5,9,10] -tn :: Z12 -> [Z12] -> [Z12] -tn = Z.tn z12_modulo - --- | Invert /p/ about /n/. --- --- > invert 6 [4,5,6] == [8,7,6] --- > invert 0 [0,1,3] == [0,11,9] -invert :: Z12 -> [Z12] -> [Z12] -invert = Z.invert z12_modulo - --- | Composition of 'invert' about @0@ and 'tn'. --- --- > tni 4 [1,5,6] == [3,11,10] --- > (invert 0 . tn 4) [1,5,6] == [7,3,2] -tni :: Z12 -> [Z12] -> [Z12] -tni = Z.tni z12_modulo - --- | Modulo 12 multiplication --- --- > mn 11 [0,1,4,9] == tni 0 [0,1,4,9] -mn :: Z12 -> [Z12] -> [Z12] -mn = Z.mn z12_modulo - --- | M5, ie. 'mn' @5@. --- --- > m5 [0,1,3] == [0,5,3] -m5 :: [Z12] -> [Z12] -m5 = mn 5 - --- | T-related sequences of /p/. --- --- > length (t_related [0,3,6,9]) == 12 -t_related :: [Z12] -> [[Z12]] -t_related = Z.t_related z12_modulo - --- | T\/I-related sequences of /p/. --- --- > length (ti_related [0,1,3]) == 24 --- > length (ti_related [0,3,6,9]) == 24 --- > ti_related [0] == map return [0..11] -ti_related :: [Z12] -> [[Z12]] -ti_related = Z.ti_related z12_modulo - --- | R\/T\/I-related sequences of /p/. --- --- > length (rti_related [0,1,3]) == 48 --- > length (rti_related [0,3,6,9]) == 24 -rti_related :: [Z12] -> [[Z12]] -rti_related = Z.rti_related z12_modulo - --- | T\/M\/I-related sequences of /p/. -tmi_related :: [Z12] -> [[Z12]] -tmi_related p = let q = ti_related p in nub (q ++ map m5 q) - --- | R\/T\/M\/I-related sequences of /p/. -rtmi_related :: [Z12] -> [[Z12]] -rtmi_related p = let q = tmi_related p in nub (q ++ map reverse q) - --- | r\/R\/T\/M\/I-related sequences of /p/. -rrtmi_related :: [Z12] -> [[Z12]] -rrtmi_related p = nub (concatMap rtmi_related (T.rotations p)) - --- * Sequence operations - --- | Variant of 'tn', transpose /p/ so first element is /n/. --- --- > tn_to 5 [0,1,3] == [5,6,8] --- > map (tn_to 0) [[0,1,3],[1,3,0],[3,0,1]] == [[0,1,3],[0,2,11],[0,9,10]] -tn_to :: Z12 -> [Z12] -> [Z12] -tn_to = Z.tn_to z12_modulo - --- | Variant of 'invert', inverse about /n/th element. --- --- > map (invert_ix 0) [[0,1,3],[3,4,6]] == [[0,11,9],[3,2,0]] --- > map (invert_ix 1) [[0,1,3],[3,4,6]] == [[2,1,11],[5,4,2]] -invert_ix :: Int -> [Z12] -> [Z12] -invert_ix = Z.invert_ix z12_modulo - --- | The standard t-matrix of /p/. --- --- > tmatrix [0,1,3] == [[0,1,3] --- > ,[11,0,2] --- > ,[9,10,0]] -tmatrix :: [Z12] -> [[Z12]] -tmatrix = Z.tmatrix z12_modulo diff --git a/Music/Theory/Z12/TTO.hs b/Music/Theory/Z12/TTO.hs deleted file mode 100644 --- a/Music/Theory/Z12/TTO.hs +++ /dev/null @@ -1,58 +0,0 @@ --- | Pitch-class set (unordered) operations on 'Z12'. -module Music.Theory.Z12.TTO where - -import Data.List -import Music.Theory.Z12 - --- | Map to pitch-class and reduce to set. --- --- > pcset [1,13] == [1] -pcset :: (Integral a) => [a] -> [Z12] -pcset = nub . sort . map fromIntegral - --- | Transpose by n. --- --- > tn 4 [1,5,6] == [5,9,10] --- > tn 4 [0,4,8] == [0,4,8] -tn :: Z12 -> [Z12] -> [Z12] -tn n = sort . map (+ n) - --- | Invert about n. --- --- > invert 6 [4,5,6] == [6,7,8] --- > invert 0 [0,1,3] == [0,9,11] -invert :: Z12 -> [Z12] -> [Z12] -invert n = sort . map (\p -> n - (p - n)) - --- | Composition of 'invert' about @0@ and 'tn'. --- --- > tni 4 [1,5,6] == [3,10,11] --- > (invert 0 . tn 4) [1,5,6] == [2,3,7] -tni :: Z12 -> [Z12] -> [Z12] -tni n = tn n . invert 0 - --- | Modulo 12 multiplication --- --- > mn 11 [0,1,4,9] == invert 0 [0,1,4,9] -mn :: Z12 -> [Z12] -> [Z12] -mn n = sort . map (* n) - --- | M5, ie. 'mn' @5@. --- --- > m5 [0,1,3] == [0,3,5] -m5 :: [Z12] -> [Z12] -m5 = mn 5 - --- | T-related sets of /p/. --- --- > length (t_related [0,1,3]) == 12 --- > t_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]] -t_related :: [Z12] -> [[Z12]] -t_related p = nub (map (`tn` p) [0..11]) - --- | T\/I-related set of /p/. --- --- > length (ti_related [0,1,3]) == 24 --- > ti_related [0,3,6,9] == [[0,3,6,9],[1,4,7,10],[2,5,8,11]] -ti_related :: [Z12] -> [[Z12]] -ti_related p = nub (t_related p ++ t_related (invert 0 p)) diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,15 +0,0 @@ -hmt - haskell music theory --------------------------- - -Music theory operations in [haskell][hs], primarily focused on 'set -theory' and 'common music notation'. - -- [hmt-diagrams][hmt-diagrams] - -[hs]: http://haskell.org/ -[hmt-diagrams]: http://rd.slavepianos.org/?t=hmt-diagrams - -© [rohan drape][rd], 2006-2014, [gpl][gpl]. - -[rd]: http://rd.slavepianos.org/ -[gpl]: http://gnu.org/copyleft/ diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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/). diff --git a/data/csv/mnd/1080-C01.csv b/data/csv/mnd/1080-C01.csv new file mode 100644 --- /dev/null +++ b/data/csv/mnd/1080-C01.csv @@ -0,0 +1,1801 @@ +time,on/off,note,velocity,channel,param +0.0000,on,62,100,1, +1.0000,off,62,0,1, +1.0000,on,69,100,1, +2.0000,off,69,0,1, +2.0000,on,65,100,1, +3.0000,off,65,0,1, +3.0000,on,62,100,1, +4.0000,off,62,0,1, +4.0000,on,61,100,1, +5.0000,off,61,0,1, +5.0000,on,62,100,1, +5.5000,off,62,0,1, +5.5000,on,64,100,1, +6.0000,off,64,0,1, +6.0000,on,65,100,1, +7.2500,off,65,0,1, +7.2500,on,67,100,1, +7.5000,off,67,0,1, +7.5000,on,65,100,1, +7.7500,off,65,0,1, +7.7500,on,64,100,1, +8.0000,off,64,0,1, +8.0000,on,69,100,0, +8.0000,on,62,100,1, +8.5000,off,62,0,1, +8.5000,on,64,100,1, +9.0000,off,69,0,0, +9.0000,off,64,0,1, +9.0000,on,74,100,0, +9.0000,on,65,100,1, +9.5000,off,65,0,1, +9.5000,on,67,100,1, +10.0000,off,74,0,0, +10.0000,off,67,0,1, +10.0000,on,72,100,0, +10.0000,on,69,100,1, +10.5000,off,69,0,1, +10.5000,on,57,100,1, +10.7500,off,57,0,1, +10.7500,on,59,100,1, +11.0000,off,72,0,0, +11.0000,off,59,0,1, +11.0000,on,69,100,0, +11.0000,on,60,100,1, +11.2500,off,60,0,1, +11.2500,on,57,100,1, +11.5000,off,57,0,1, +11.5000,on,65,100,1, +12.0000,off,69,0,0, +12.0000,on,68,100,0, +12.2500,off,65,0,1, +12.2500,on,59,100,1, +12.5000,off,59,0,1, +12.5000,on,64,100,1, +13.0000,off,68,0,0, +13.0000,on,69,100,0, +13.2500,off,64,0,1, +13.2500,on,65,100,1, +13.5000,off,69,0,0, +13.5000,off,65,0,1, +13.5000,on,71,100,0, +13.5000,on,64,100,1, +13.7500,off,64,0,1, +13.7500,on,62,100,1, +14.0000,off,71,0,0, +14.0000,off,62,0,1, +14.0000,on,72,100,0, +14.0000,on,64,100,1, +14.5000,off,64,0,1, +14.5000,on,66,100,1, +15.0000,off,66,0,1, +15.0000,on,67,100,1, +15.2500,off,72,0,0, +15.2500,on,74,100,0, +15.5000,off,74,0,0, +15.5000,on,72,100,0, +15.7500,off,72,0,0, +15.7500,on,70,100,0, +16.0000,off,70,0,0, +16.0000,on,69,100,0, +16.0000,on,50,100,3, +16.2500,off,69,0,0, +16.2500,on,62,100,0, +16.5000,off,67,0,1, +16.5000,off,62,0,0, +16.5000,on,74,100,0, +16.5000,on,65,100,1, +17.0000,off,50,0,3, +17.0000,off,65,0,1, +17.0000,on,64,100,1, +17.0000,on,57,100,3, +17.5000,off,74,0,0, +17.5000,on,73,100,0, +18.0000,off,64,0,1, +18.0000,off,57,0,3, +18.0000,off,73,0,0, +18.0000,on,74,100,0, +18.0000,on,62,100,1, +18.0000,on,53,100,3, +18.2500,off,74,0,0, +18.2500,on,69,100,0, +18.5000,off,69,0,0, +18.5000,on,72,100,0, +18.7500,off,62,0,1, +18.7500,on,64,100,1, +19.0000,off,53,0,3, +19.0000,off,64,0,1, +19.0000,on,65,100,1, +19.0000,on,50,100,3, +19.2500,off,72,0,0, +19.2500,on,69,100,0, +19.5000,off,69,0,0, +19.5000,on,70,100,0, +19.7500,off,65,0,1, +19.7500,on,62,100,1, +20.0000,off,50,0,3, +20.0000,off,62,0,1, +20.0000,on,67,100,1, +20.0000,on,49,100,3, +20.2500,off,70,0,0, +20.2500,on,64,100,0, +20.5000,off,64,0,0, +20.5000,on,69,100,0, +20.7500,off,67,0,1, +20.7500,on,67,100,1, +21.0000,off,49,0,3, +21.0000,off,67,0,1, +21.0000,on,65,100,1, +21.0000,on,50,100,3, +21.2500,off,65,0,1, +21.2500,on,64,100,1, +21.5000,off,50,0,3, +21.5000,off,64,0,1, +21.5000,on,62,100,1, +21.5000,on,52,100,3, +21.7500,off,62,0,1, +21.7500,on,61,100,1, +22.0000,off,69,0,0, +22.0000,off,52,0,3, +22.0000,off,61,0,1, +22.0000,on,69,100,0, +22.0000,on,62,100,1, +22.0000,on,53,100,3, +22.2500,off,69,0,0, +22.2500,on,72,100,0, +22.5000,off,62,0,1, +22.5000,on,67,100,1, +22.7500,off,72,0,0, +22.7500,on,71,100,0, +23.0000,off,71,0,0, +23.0000,on,72,100,0, +23.2500,off,53,0,3, +23.2500,on,55,100,3, +23.5000,off,67,0,1, +23.5000,off,55,0,3, +23.5000,on,60,100,1, +23.5000,on,53,100,3, +23.7500,off,53,0,3, +23.7500,on,52,100,3, +24.0000,off,60,0,1, +24.0000,off,52,0,3, +24.0000,on,65,100,1, +24.0000,on,57,100,2, +24.0000,on,50,100,3, +24.2500,off,72,0,0, +24.2500,on,62,100,0, +24.5000,off,62,0,0, +24.5000,on,72,100,0, +24.7500,off,65,0,1, +24.7500,on,64,100,1, +25.0000,off,57,0,2, +25.0000,off,50,0,3, +25.0000,off,64,0,1, +25.0000,on,65,100,1, +25.0000,on,62,100,2, +25.2500,off,72,0,0, +25.2500,on,69,100,0, +25.5000,off,69,0,0, +25.5000,on,71,100,0, +25.7500,off,65,0,1, +25.7500,on,56,100,1, +26.0000,off,62,0,2, +26.0000,off,56,0,1, +26.0000,on,64,100,1, +26.0000,on,60,100,2, +26.5000,off,71,0,0, +26.5000,on,69,100,0, +26.5000,on,45,100,3, +26.7500,off,69,0,0, +26.7500,off,45,0,3, +26.7500,on,68,100,0, +26.7500,on,47,100,3, +27.0000,off,60,0,2, +27.0000,off,68,0,0, +27.0000,off,47,0,3, +27.0000,on,69,100,0, +27.0000,on,57,100,2, +27.0000,on,48,100,3, +27.2500,off,48,0,3, +27.2500,on,45,100,3, +27.5000,off,64,0,1, +27.5000,off,45,0,3, +27.5000,on,62,100,1, +27.5000,on,53,100,3, +27.7500,off,62,0,1, +27.7500,on,60,100,1, +28.0000,off,69,0,0, +28.0000,off,57,0,2, +28.0000,off,60,0,1, +28.0000,on,71,100,0, +28.0000,on,62,100,1, +28.0000,on,56,100,2, +28.2500,off,53,0,3, +28.2500,off,62,0,1, +28.2500,on,65,100,1, +28.2500,on,47,100,3, +28.5000,off,65,0,1, +28.5000,off,47,0,3, +28.5000,on,64,100,1, +28.5000,on,52,100,3, +28.7500,off,64,0,1, +28.7500,on,62,100,1, +29.0000,off,71,0,0, +29.0000,off,56,0,2, +29.0000,off,62,0,1, +29.0000,on,72,100,0, +29.0000,on,60,100,1, +29.0000,on,57,100,2, +29.2500,off,52,0,3, +29.2500,on,53,100,3, +29.5000,off,72,0,0, +29.5000,off,60,0,1, +29.5000,off,57,0,2, +29.5000,off,53,0,3, +29.5000,on,74,100,0, +29.5000,on,59,100,2, +29.5000,on,52,100,3, +29.7500,off,52,0,3, +29.7500,on,50,100,3, +30.0000,off,74,0,0, +30.0000,off,59,0,2, +30.0000,off,50,0,3, +30.0000,on,67,100,0, +30.0000,on,60,100,2, +30.0000,on,52,100,3, +30.2500,off,67,0,0, +30.2500,off,52,0,3, +30.2500,on,70,100,0, +30.2500,on,55,100,3, +30.5000,off,70,0,0, +30.5000,off,55,0,3, +30.5000,on,69,100,0, +30.5000,on,54,100,3, +30.7500,off,54,0,3, +30.7500,on,57,100,3, +31.0000,off,57,0,3, +31.0000,on,55,100,3, +31.2500,off,60,0,2, +31.2500,off,69,0,0, +31.2500,on,70,100,0, +31.2500,on,62,100,2, +31.5000,off,70,0,0, +31.5000,off,62,0,2, +31.5000,on,69,100,0, +31.5000,on,60,100,2, +31.7500,off,69,0,0, +31.7500,off,60,0,2, +31.7500,on,67,100,0, +31.7500,on,58,100,2, +32.0000,off,55,0,3, +32.0000,off,58,0,2, +32.0000,on,57,100,2, +32.0000,on,50,100,3, +32.2500,off,67,0,0, +32.2500,on,64,100,0, +32.5000,off,64,0,0, +32.5000,on,65,100,0, +32.7500,off,65,0,0, +32.7500,on,62,100,0, +33.0000,off,62,0,0, +33.0000,on,70,100,0, +33.2500,off,57,0,2, +33.2500,on,53,100,2, +33.5000,off,50,0,3, +33.5000,off,53,0,2, +33.5000,on,55,100,2, +33.5000,on,52,100,3, +33.7500,off,52,0,3, +33.7500,on,50,100,3, +34.0000,off,55,0,2, +34.0000,off,50,0,3, +34.0000,on,60,100,2, +34.0000,on,52,100,3, +34.2500,off,70,0,0, +34.2500,on,67,100,0, +34.5000,off,52,0,3, +34.5000,off,67,0,0, +34.5000,on,69,100,0, +34.5000,on,53,100,3, +34.7500,off,53,0,3, +34.7500,on,52,100,3, +35.0000,off,69,0,0, +35.0000,off,52,0,3, +35.0000,on,74,100,0, +35.0000,on,54,100,3, +35.2500,off,60,0,2, +35.2500,on,57,100,2, +35.5000,off,54,0,3, +35.5000,off,57,0,2, +35.5000,on,59,100,2, +35.5000,on,55,100,3, +35.7500,off,55,0,3, +35.7500,on,54,100,3, +36.0000,off,59,0,2, +36.0000,off,54,0,3, +36.0000,on,64,100,2, +36.0000,on,56,100,3, +36.2500,off,74,0,0, +36.2500,on,71,100,0, +36.5000,off,56,0,3, +36.5000,off,71,0,0, +36.5000,on,72,100,0, +36.5000,on,57,100,3, +36.7500,off,57,0,3, +36.7500,on,56,100,3, +37.0000,off,72,0,0, +37.0000,off,56,0,3, +37.0000,on,77,100,0, +37.0000,on,57,100,3, +37.2500,off,64,0,2, +37.2500,on,61,100,2, +37.5000,off,57,0,3, +37.5000,off,61,0,2, +37.5000,on,62,100,2, +37.5000,on,58,100,3, +37.7500,off,58,0,3, +37.7500,on,57,100,3, +38.0000,off,62,0,2, +38.0000,off,57,0,3, +38.0000,on,67,100,2, +38.0000,on,59,100,3, +38.2500,off,77,0,0, +38.2500,on,74,100,0, +38.5000,off,59,0,3, +38.5000,off,74,0,0, +38.5000,on,76,100,0, +38.5000,on,60,100,3, +38.7500,off,60,0,3, +38.7500,on,59,100,3, +39.0000,off,76,0,0, +39.0000,off,59,0,3, +39.0000,on,69,100,0, +39.0000,on,61,100,3, +39.2500,off,67,0,2, +39.2500,on,64,100,2, +39.5000,off,69,0,0, +39.5000,off,61,0,3, +39.5000,off,64,0,2, +39.5000,on,74,100,0, +39.5000,on,65,100,2, +39.5000,on,62,100,3, +39.7500,off,62,0,3, +39.7500,on,56,100,3, +40.0000,off,65,0,2, +40.0000,off,56,0,3, +40.0000,on,64,100,2, +40.0000,on,57,100,3, +40.2500,off,74,0,0, +40.2500,on,71,100,0, +40.5000,off,71,0,0, +40.5000,on,72,100,0, +40.7500,off,64,0,2, +40.7500,on,69,100,2, +41.0000,off,72,0,0, +41.0000,off,69,0,2, +41.0000,on,65,100,0, +41.0000,on,62,100,2, +41.2500,off,57,0,3, +41.2500,on,53,100,3, +41.5000,off,65,0,0, +41.5000,off,53,0,3, +41.5000,on,70,100,0, +41.5000,on,55,100,3, +41.7500,off,62,0,2, +41.7500,on,64,100,2, +42.0000,off,70,0,0, +42.0000,off,64,0,2, +42.0000,on,69,100,0, +42.0000,on,61,100,2, +42.2500,off,55,0,3, +42.2500,on,52,100,3, +42.5000,off,61,0,2, +42.5000,off,52,0,3, +42.5000,on,62,100,2, +42.5000,on,53,100,3, +42.7500,off,62,0,2, +42.7500,on,57,100,2, +43.0000,off,69,0,0, +43.0000,off,57,0,2, +43.0000,on,62,100,0, +43.0000,on,59,100,2, +43.2500,off,53,0,3, +43.2500,on,50,100,3, +43.5000,off,62,0,0, +43.5000,off,50,0,3, +43.5000,on,67,100,0, +43.5000,on,52,100,3, +43.7500,off,59,0,2, +43.7500,on,61,100,2, +44.0000,off,52,0,3, +44.0000,off,61,0,2, +44.0000,on,62,100,1, +44.0000,on,62,100,2, +44.0000,on,50,100,3, +44.2500,off,67,0,0, +44.2500,on,64,100,0, +44.5000,off,62,0,2, +44.5000,off,64,0,0, +44.5000,on,65,100,0, +44.5000,on,57,100,2, +44.7500,off,65,0,0, +44.7500,on,74,100,0, +45.0000,off,62,0,1, +45.0000,off,74,0,0, +45.0000,on,64,100,0, +45.0000,on,69,100,1, +45.2500,off,50,0,3, +45.2500,on,47,100,3, +45.5000,off,47,0,3, +45.5000,on,49,100,3, +46.0000,off,69,0,1, +46.0000,off,49,0,3, +46.0000,on,65,100,1, +46.0000,on,50,100,3, +46.2500,off,64,0,0, +46.2500,on,62,100,0, +46.5000,off,62,0,0, +46.5000,on,69,100,0, +46.7500,off,50,0,3, +46.7500,on,48,100,3, +47.0000,off,57,0,2, +47.0000,off,65,0,1, +47.0000,off,48,0,3, +47.0000,on,62,100,1, +47.0000,on,58,100,2, +47.0000,on,46,100,3, +47.5000,off,69,0,0, +47.5000,on,67,100,0, +48.0000,off,62,0,1, +48.0000,off,58,0,2, +48.0000,off,46,0,3, +48.0000,off,67,0,0, +48.0000,on,69,100,0, +48.0000,on,61,100,1, +48.0000,on,45,100,3, +48.2500,on,52,100,2, +48.5000,off,52,0,2, +48.5000,on,57,100,2, +48.7500,off,45,0,3, +48.7500,on,43,100,3, +49.0000,off,69,0,0, +49.0000,off,61,0,1, +49.0000,off,43,0,3, +49.0000,on,62,100,1, +49.0000,on,41,100,3, +49.2500,off,57,0,2, +49.2500,off,41,0,3, +49.2500,on,58,100,2, +49.2500,on,43,100,3, +49.5000,off,62,0,1, +49.5000,off,58,0,2, +49.5000,off,43,0,3, +49.5000,on,64,100,1, +49.5000,on,57,100,2, +49.5000,on,41,100,3, +49.7500,off,57,0,2, +49.7500,off,41,0,3, +49.7500,on,55,100,2, +49.7500,on,40,100,3, +50.0000,off,64,0,1, +50.0000,off,55,0,2, +50.0000,off,40,0,3, +50.0000,on,65,100,1, +50.0000,on,57,100,2, +50.0000,on,38,100,3, +50.2500,off,38,0,3, +50.2500,on,41,100,3, +50.5000,off,57,0,2, +50.5000,off,41,0,3, +50.5000,on,59,100,2, +50.5000,on,40,100,3, +50.7500,off,40,0,3, +50.7500,on,38,100,3, +51.0000,off,59,0,2, +51.0000,off,38,0,3, +51.0000,on,60,100,2, +51.0000,on,45,100,3, +51.2500,off,65,0,1, +51.2500,on,67,100,1, +51.5000,off,67,0,1, +51.5000,on,65,100,1, +51.7500,off,45,0,3, +51.7500,off,65,0,1, +51.7500,on,64,100,1, +51.7500,on,41,100,3, +52.0000,off,64,0,1, +52.0000,off,41,0,3, +52.0000,on,62,100,1, +52.0000,on,46,100,3, +52.2500,off,60,0,2, +52.2500,on,57,100,2, +52.5000,off,62,0,1, +52.5000,off,57,0,2, +52.5000,on,67,100,1, +52.5000,on,58,100,2, +52.7500,off,46,0,3, +52.7500,on,43,100,3, +53.0000,off,58,0,2, +53.0000,off,43,0,3, +53.0000,on,57,100,2, +53.0000,on,50,100,3, +53.2500,off,67,0,1, +53.2500,on,64,100,1, +53.5000,off,57,0,2, +53.5000,off,64,0,1, +53.5000,on,65,100,1, +53.5000,on,62,100,2, +53.7500,off,50,0,3, +53.7500,on,53,100,3, +54.0000,off,65,0,1, +54.0000,off,53,0,3, +54.0000,on,64,100,1, +54.0000,on,57,100,3, +54.2500,off,62,0,2, +54.2500,on,59,100,2, +54.5000,off,64,0,1, +54.5000,off,59,0,2, +54.5000,on,69,100,1, +54.5000,on,60,100,2, +54.7500,off,57,0,3, +54.7500,on,45,100,3, +55.0000,off,60,0,2, +55.0000,off,45,0,3, +55.0000,on,59,100,2, +55.0000,on,40,100,3, +55.2500,off,69,0,1, +55.2500,on,66,100,1, +55.5000,off,59,0,2, +55.5000,off,66,0,1, +55.5000,on,67,100,1, +55.5000,on,64,100,2, +56.0000,off,40,0,3, +56.0000,off,67,0,1, +56.0000,on,69,100,0, +56.0000,on,66,100,1, +56.2500,off,64,0,2, +56.2500,on,57,100,2, +56.5000,off,57,0,2, +56.5000,on,62,100,2, +56.7500,off,66,0,1, +56.7500,on,74,100,1, +57.0000,off,69,0,0, +57.0000,off,74,0,1, +57.0000,on,76,100,0, +57.0000,on,68,100,1, +57.0000,on,52,100,3, +57.2500,off,62,0,2, +57.2500,on,62,100,2, +57.5000,off,62,0,2, +57.5000,on,60,100,2, +57.7500,off,60,0,2, +57.7500,on,59,100,2, +58.0000,off,76,0,0, +58.0000,off,68,0,1, +58.0000,off,52,0,3, +58.0000,off,59,0,2, +58.0000,on,72,100,0, +58.0000,on,69,100,1, +58.0000,on,60,100,2, +58.0000,on,57,100,3, +58.2500,off,60,0,2, +58.2500,on,62,100,2, +58.5000,off,69,0,1, +58.5000,off,62,0,2, +58.5000,on,64,100,2, +58.7500,on,57,100,1, +59.0000,off,72,0,0, +59.0000,off,57,0,3, +59.0000,off,57,0,1, +59.0000,on,69,100,0, +59.0000,on,60,100,1, +59.0000,on,53,100,3, +59.2500,off,64,0,2, +59.2500,on,64,100,2, +59.5000,off,60,0,1, +59.5000,off,64,0,2, +59.5000,on,57,100,1, +59.5000,on,62,100,2, +59.7500,off,62,0,2, +59.7500,on,60,100,2, +60.0000,off,69,0,0, +60.0000,off,57,0,1, +60.0000,off,60,0,2, +60.0000,on,68,100,0, +60.0000,on,62,100,1, +60.0000,on,59,100,2, +60.2500,off,53,0,3, +60.2500,on,53,100,3, +60.5000,off,62,0,1, +60.5000,off,53,0,3, +60.5000,on,65,100,1, +60.5000,on,52,100,3, +60.7500,off,52,0,3, +60.7500,on,50,100,3, +61.0000,off,68,0,0, +61.0000,off,59,0,2, +61.0000,off,65,0,1, +61.0000,off,50,0,3, +61.0000,on,69,100,0, +61.0000,on,64,100,1, +61.0000,on,60,100,2, +61.0000,on,48,100,3, +61.2500,off,48,0,3, +61.2500,on,50,100,3, +61.5000,off,69,0,0, +61.5000,off,64,0,1, +61.5000,off,60,0,2, +61.5000,off,50,0,3, +61.5000,on,71,100,0, +61.5000,on,62,100,1, +61.5000,on,56,100,2, +61.5000,on,48,100,3, +61.7500,off,48,0,3, +61.7500,on,47,100,3, +62.0000,off,71,0,0, +62.0000,off,62,0,1, +62.0000,off,56,0,2, +62.0000,off,47,0,3, +62.0000,on,72,100,0, +62.0000,on,60,100,1, +62.0000,on,57,100,2, +62.0000,on,45,100,3, +62.2500,off,57,0,2, +62.2500,on,55,100,2, +62.5000,off,60,0,1, +62.5000,off,55,0,2, +62.5000,on,69,100,1, +62.5000,on,54,100,2, +62.7500,off,54,0,2, +62.7500,on,52,100,2, +63.0000,off,45,0,3, +63.0000,off,52,0,2, +63.0000,on,54,100,2, +63.0000,on,50,100,3, +63.2500,off,72,0,0, +63.2500,on,74,100,0, +63.5000,off,69,0,1, +63.5000,off,54,0,2, +63.5000,off,74,0,0, +63.5000,on,72,100,0, +63.5000,on,62,100,1, +63.5000,on,55,100,2, +63.7500,off,72,0,0, +63.7500,on,70,100,0, +64.0000,off,50,0,3, +64.0000,off,62,0,1, +64.0000,off,70,0,0, +64.0000,on,69,100,0, +64.0000,on,64,100,1, +64.0000,on,49,100,3, +64.2500,off,55,0,2, +64.2500,on,55,100,2, +64.5000,off,69,0,0, +64.5000,off,64,0,1, +64.5000,off,55,0,2, +64.5000,on,69,100,1, +64.5000,on,53,100,2, +64.7500,off,53,0,2, +64.7500,on,52,100,2, +65.0000,off,49,0,3, +65.0000,off,52,0,2, +65.0000,on,53,100,2, +65.0000,on,45,100,3, +65.2500,off,69,0,1, +65.2500,off,53,0,2, +65.2500,on,67,100,1, +65.2500,on,52,100,2, +65.5000,off,67,0,1, +65.5000,off,52,0,2, +65.5000,on,69,100,0, +65.5000,on,65,100,1, +65.5000,on,50,100,2, +65.7500,off,65,0,1, +65.7500,off,50,0,2, +65.7500,on,64,100,1, +65.7500,on,49,100,2, +66.0000,off,45,0,3, +66.0000,off,64,0,1, +66.0000,off,49,0,2, +66.0000,on,62,100,1, +66.0000,on,50,100,2, +66.0000,on,42,100,3, +66.2500,off,69,0,0, +66.2500,on,72,100,0, +66.5000,off,50,0,2, +66.5000,off,72,0,0, +66.5000,on,70,100,0, +66.7500,off,70,0,0, +66.7500,on,69,100,0, +67.0000,off,42,0,3, +67.0000,off,69,0,0, +67.0000,on,70,100,0, +67.0000,on,43,100,3, +67.2500,off,70,0,0, +67.2500,on,69,100,0, +67.5000,off,43,0,3, +67.5000,off,69,0,0, +67.5000,on,67,100,0, +67.5000,on,45,100,3, +67.7500,off,67,0,0, +67.7500,on,66,100,0, +68.0000,off,45,0,3, +68.0000,off,66,0,0, +68.0000,on,67,100,0, +68.0000,on,46,100,3, +68.2500,off,62,0,1, +68.2500,on,62,100,1, +68.5000,off,62,0,1, +68.5000,on,67,100,1, +68.7500,off,67,0,0, +68.7500,on,70,100,0, +69.0000,off,70,0,0, +69.0000,on,64,100,0, +69.2500,off,46,0,3, +69.2500,off,67,0,1, +69.2500,on,67,100,1, +69.2500,on,48,100,3, +69.5000,off,67,0,1, +69.5000,off,48,0,3, +69.5000,on,60,100,1, +69.5000,on,46,100,3, +69.7500,off,64,0,0, +69.7500,off,46,0,3, +69.7500,on,66,100,0, +69.7500,on,45,100,3, +70.0000,off,66,0,0, +70.0000,off,45,0,3, +70.0000,on,67,100,0, +70.0000,on,43,100,3, +70.2500,off,60,0,1, +70.2500,on,57,100,1, +70.5000,off,57,0,1, +70.5000,on,58,100,1, +70.7500,off,67,0,0, +70.7500,on,64,100,0, +71.0000,off,58,0,1, +71.0000,off,64,0,0, +71.0000,on,61,100,0, +71.0000,on,57,100,1, +71.2500,off,43,0,3, +71.2500,on,40,100,3, +71.5000,off,40,0,3, +71.5000,on,41,100,3, +71.7500,off,61,0,0, +71.7500,on,69,100,0, +72.0000,off,41,0,3, +72.0000,off,69,0,0, +72.0000,on,62,100,0, +72.0000,on,46,100,3, +72.2500,off,57,0,1, +72.2500,on,53,100,1, +72.5000,off,53,0,1, +72.5000,on,55,100,1, +72.7500,off,62,0,0, +72.7500,on,65,100,0, +73.0000,off,55,0,1, +73.0000,off,65,0,0, +73.0000,on,64,100,0, +73.0000,on,60,100,1, +73.2500,off,46,0,3, +73.2500,on,43,100,3, +73.5000,off,43,0,3, +73.5000,on,45,100,3, +73.7500,off,64,0,0, +73.7500,on,72,100,0, +74.0000,off,45,0,3, +74.0000,off,72,0,0, +74.0000,on,65,100,0, +74.0000,on,50,100,3, +74.2500,off,60,0,1, +74.2500,on,57,100,1, +74.5000,off,57,0,1, +74.5000,on,59,100,1, +74.7500,off,65,0,0, +74.7500,on,69,100,0, +75.0000,off,59,0,1, +75.0000,off,69,0,0, +75.0000,on,67,100,0, +75.0000,on,64,100,1, +75.2500,off,50,0,3, +75.2500,on,47,100,3, +75.5000,off,47,0,3, +75.5000,on,48,100,3, +75.7500,off,67,0,0, +75.7500,on,76,100,0, +76.0000,off,48,0,3, +76.0000,off,76,0,0, +76.0000,on,69,100,0, +76.0000,on,53,100,3, +76.2500,off,64,0,1, +76.2500,on,61,100,1, +76.5000,off,61,0,1, +76.5000,on,62,100,1, +76.7500,off,69,0,0, +76.7500,on,72,100,0, +77.0000,off,62,0,1, +77.0000,off,72,0,0, +77.0000,on,71,100,0, +77.0000,on,67,100,1, +77.2500,off,53,0,3, +77.2500,on,50,100,3, +77.5000,off,50,0,3, +77.5000,on,52,100,3, +77.7500,off,71,0,0, +77.7500,on,79,100,0, +78.0000,off,52,0,3, +78.0000,off,79,0,0, +78.0000,on,73,100,0, +78.0000,on,52,100,2, +78.0000,on,45,100,3, +78.2500,off,67,0,1, +78.2500,on,69,100,1, +78.5000,off,69,0,1, +78.5000,on,70,100,1, +78.7500,off,45,0,3, +78.7500,on,55,100,3, +79.0000,off,73,0,0, +79.0000,off,52,0,2, +79.0000,off,70,0,1, +79.0000,off,55,0,3, +79.0000,on,74,100,0, +79.0000,on,69,100,1, +79.0000,on,57,100,2, +79.0000,on,53,100,3, +79.2500,off,53,0,3, +79.2500,on,52,100,3, +79.5000,off,74,0,0, +79.5000,off,52,0,3, +79.5000,on,76,100,0, +79.5000,on,50,100,3, +79.7500,off,50,0,3, +79.7500,on,49,100,3, +80.0000,off,57,0,2, +80.0000,off,49,0,3, +80.0000,on,53,100,2, +80.0000,on,50,100,3, +80.2500,off,76,0,0, +80.2500,on,73,100,0, +80.5000,off,73,0,0, +80.5000,on,74,100,0, +80.7500,off,50,0,3, +80.7500,on,41,100,3, +81.0000,off,53,0,2, +81.0000,off,41,0,3, +81.0000,on,50,100,2, +81.0000,on,46,100,3, +81.2500,off,69,0,1, +81.2500,on,65,100,1, +81.5000,off,65,0,1, +81.5000,on,67,100,1, +81.7500,off,74,0,0, +81.7500,on,76,100,0, +82.0000,off,50,0,2, +82.0000,off,46,0,3, +82.0000,off,67,0,1, +82.0000,off,76,0,0, +82.0000,on,77,100,0, +82.0000,on,69,100,1, +82.0000,on,49,100,2, +82.0000,on,45,100,3, +82.2500,off,77,0,0, +82.2500,on,76,100,0, +82.5000,off,76,0,0, +82.5000,on,79,100,0, +82.7500,off,69,0,1, +82.7500,on,70,100,1, +83.0000,off,49,0,2, +83.0000,off,70,0,1, +83.0000,on,69,100,1, +83.0000,on,50,100,2, +83.2500,off,79,0,0, +83.2500,on,77,100,0, +83.5000,off,69,0,1, +83.5000,off,50,0,2, +83.5000,off,77,0,0, +83.5000,on,76,100,0, +83.5000,on,67,100,1, +83.5000,on,52,100,2, +83.7500,off,76,0,0, +83.7500,on,74,100,0, +84.0000,off,52,0,2, +84.0000,off,74,0,0, +84.0000,on,73,100,0, +84.0000,on,53,100,2, +84.2500,off,73,0,0, +84.2500,on,69,100,0, +84.5000,off,67,0,1, +84.5000,off,69,0,0, +84.5000,on,74,100,0, +84.5000,on,65,100,1, +84.7500,off,45,0,3, +84.7500,off,65,0,1, +84.7500,on,62,100,1, +84.7500,on,46,100,3, +85.0000,off,62,0,1, +85.0000,off,46,0,3, +85.0000,on,69,100,1, +85.0000,on,45,100,3, +85.2500,off,53,0,2, +85.2500,off,74,0,0, +85.2500,off,45,0,3, +85.2500,on,71,100,0, +85.2500,on,55,100,2, +85.2500,on,43,100,3, +85.5000,off,71,0,0, +85.5000,off,55,0,2, +85.5000,off,43,0,3, +85.5000,on,72,100,0, +85.5000,on,53,100,2, +85.5000,on,45,100,3, +85.7500,off,69,0,1, +85.7500,off,53,0,2, +85.7500,on,67,100,1, +85.7500,on,52,100,2, +86.0000,off,72,0,0, +86.0000,off,45,0,3, +86.0000,off,67,0,1, +86.0000,off,52,0,2, +86.0000,on,72,100,0, +86.0000,on,66,100,1, +86.0000,on,50,100,2, +86.0000,on,46,100,3, +86.2500,off,66,0,1, +86.2500,on,62,100,1, +86.5000,off,72,0,0, +86.5000,off,62,0,1, +86.5000,on,70,100,0, +86.5000,on,67,100,1, +86.7500,off,46,0,3, +86.7500,on,43,100,3, +87.0000,off,70,0,0, +87.0000,off,43,0,3, +87.0000,on,69,100,0, +87.0000,on,50,100,3, +87.2500,off,67,0,1, +87.2500,on,64,100,1, +87.5000,off,50,0,2, +87.5000,off,69,0,0, +87.5000,off,64,0,1, +87.5000,on,65,100,1, +87.5000,on,57,100,2, +87.7500,off,57,0,2, +87.7500,on,53,100,2, +88.0000,off,53,0,2, +88.0000,on,58,100,2, +88.2500,off,65,0,1, +88.2500,on,62,100,1, +88.5000,off,50,0,3, +88.5000,off,62,0,1, +88.5000,on,67,100,1, +88.5000,on,52,100,3, +88.7500,off,58,0,2, +88.7500,on,55,100,2, +89.0000,off,55,0,2, +89.0000,on,60,100,2, +89.2500,off,67,0,1, +89.2500,on,64,100,1, +89.5000,off,52,0,3, +89.5000,off,64,0,1, +89.5000,on,69,100,1, +89.5000,on,53,100,3, +89.7500,off,60,0,2, +89.7500,on,57,100,2, +90.0000,off,57,0,2, +90.0000,on,62,100,2, +90.2500,off,69,0,1, +90.2500,on,65,100,1, +90.5000,off,62,0,2, +90.5000,off,65,0,1, +90.5000,on,70,100,1, +90.5000,on,55,100,2, +90.7500,off,53,0,3, +90.7500,on,50,100,3, +91.0000,off,55,0,2, +91.0000,off,50,0,3, +91.0000,on,60,100,2, +91.0000,on,52,100,3, +91.2500,off,70,0,1, +91.2500,on,67,100,1, +91.5000,off,60,0,2, +91.5000,off,67,0,1, +91.5000,on,69,100,1, +91.5000,on,53,100,2, +91.7500,off,52,0,3, +91.7500,on,49,100,3, +92.0000,off,53,0,2, +92.0000,off,49,0,3, +92.0000,on,58,100,2, +92.0000,on,50,100,3, +92.2500,off,69,0,1, +92.2500,on,65,100,1, +92.5000,off,58,0,2, +92.5000,off,65,0,1, +92.5000,on,67,100,1, +92.5000,on,52,100,2, +92.7500,off,50,0,3, +92.7500,on,47,100,3, +93.0000,off,52,0,2, +93.0000,off,47,0,3, +93.0000,on,57,100,2, +93.0000,on,49,100,3, +93.2500,off,49,0,3, +93.2500,on,45,100,3, +93.5000,off,67,0,1, +93.5000,off,45,0,3, +93.5000,on,65,100,1, +93.5000,on,50,100,3, +93.7500,off,65,0,1, +93.7500,on,62,100,1, +94.0000,off,57,0,2, +94.0000,off,62,0,1, +94.0000,on,69,100,1, +94.0000,on,52,100,2, +94.2500,off,50,0,3, +94.2500,on,48,100,3, +94.5000,off,52,0,2, +94.5000,off,48,0,3, +94.5000,on,57,100,2, +94.5000,on,47,100,3, +94.7500,off,47,0,3, +94.7500,on,45,100,3, +95.0000,off,69,0,1, +95.0000,off,45,0,3, +95.0000,on,74,100,1, +95.0000,on,47,100,3, +95.2500,off,57,0,2, +95.2500,on,56,100,2, +95.5000,off,56,0,2, +95.5000,on,54,100,2, +95.7500,off,54,0,2, +95.7500,on,56,100,2, +96.0000,off,47,0,3, +96.0000,off,56,0,2, +96.0000,on,76,100,0, +96.0000,on,57,100,2, +96.0000,on,45,100,3, +96.2500,off,74,0,1, +96.2500,on,73,100,1, +96.5000,off,45,0,3, +96.5000,off,73,0,1, +96.5000,on,71,100,1, +96.7500,off,57,0,2, +96.7500,off,71,0,1, +96.7500,on,73,100,1, +96.7500,on,55,100,2, +97.0000,off,76,0,0, +97.0000,off,73,0,1, +97.0000,off,55,0,2, +97.0000,on,81,100,0, +97.0000,on,74,100,1, +97.0000,on,53,100,2, +97.2500,off,74,0,1, +97.2500,off,53,0,2, +97.2500,on,69,100,1, +97.2500,on,52,100,2, +97.5000,off,69,0,1, +97.5000,off,52,0,2, +97.5000,on,76,100,1, +97.5000,on,50,100,2, +97.7500,off,50,0,2, +97.7500,on,49,100,2, +98.0000,off,81,0,0, +98.0000,off,49,0,2, +98.0000,on,77,100,0, +98.0000,on,50,100,2, +98.2500,off,76,0,1, +98.2500,on,69,100,1, +98.5000,off,50,0,2, +98.5000,off,69,0,1, +98.5000,on,74,100,1, +98.5000,on,53,100,2, +98.7500,off,53,0,2, +98.7500,on,50,100,2, +99.0000,off,77,0,0, +99.0000,off,74,0,1, +99.0000,off,50,0,2, +99.0000,on,74,100,0, +99.0000,on,58,100,2, +99.2500,on,65,100,1, +99.5000,off,58,0,2, +99.5000,off,65,0,1, +99.5000,on,70,100,1, +99.5000,on,55,100,2, +99.7500,off,55,0,2, +99.7500,on,52,100,2, +100.0000,off,74,0,0, +100.0000,off,52,0,2, +100.0000,on,73,100,0, +100.0000,on,57,100,2, +100.2500,off,70,0,1, +100.2500,on,64,100,1, +100.5000,off,64,0,1, +100.5000,on,69,100,1, +100.7500,off,57,0,2, +100.7500,on,65,100,2, +101.0000,off,73,0,0, +101.0000,off,65,0,2, +101.0000,on,74,100,0, +101.0000,on,59,100,2, +101.2500,off,69,0,1, +101.2500,on,67,100,1, +101.5000,off,74,0,0, +101.5000,off,59,0,2, +101.5000,off,67,0,1, +101.5000,on,76,100,0, +101.5000,on,65,100,1, +101.5000,on,61,100,2, +101.7500,off,65,0,1, +101.7500,on,64,100,1, +102.0000,off,76,0,0, +102.0000,off,61,0,2, +102.0000,off,64,0,1, +102.0000,on,77,100,0, +102.0000,on,62,100,1, +102.0000,on,62,100,2, +102.2500,off,62,0,1, +102.2500,on,69,100,1, +102.5000,off,62,0,2, +102.5000,off,69,0,1, +102.5000,on,74,100,1, +102.5000,on,59,100,2, +102.7500,off,74,0,1, +102.7500,off,59,0,2, +102.7500,on,71,100,1, +102.7500,on,55,100,2, +103.0000,off,71,0,1, +103.0000,off,55,0,2, +103.0000,on,67,100,1, +103.0000,on,60,100,2, +103.2500,off,77,0,0, +103.2500,off,67,0,1, +103.2500,on,79,100,0, +103.2500,on,64,100,1, +103.5000,off,60,0,2, +103.5000,off,79,0,0, +103.5000,off,64,0,1, +103.5000,on,77,100,0, +103.5000,on,72,100,1, +103.5000,on,57,100,2, +103.7500,off,77,0,0, +103.7500,off,57,0,2, +103.7500,on,76,100,0, +103.7500,on,53,100,2, +104.0000,off,76,0,0, +104.0000,off,53,0,2, +104.0000,on,74,100,0, +104.0000,on,58,100,2, +104.2500,off,58,0,2, +104.2500,on,62,100,2, +104.5000,off,72,0,1, +104.5000,off,62,0,2, +104.5000,on,70,100,1, +104.5000,on,67,100,2, +104.7500,off,74,0,0, +104.7500,on,76,100,0, +105.0000,off,70,0,1, +105.0000,off,76,0,0, +105.0000,on,73,100,0, +105.0000,on,69,100,1, +105.2500,off,67,0,2, +105.2500,on,64,100,2, +105.5000,off,73,0,0, +105.5000,off,64,0,2, +105.5000,on,74,100,0, +105.5000,on,65,100,2, +105.7500,off,74,0,0, +105.7500,on,77,100,0, +106.0000,off,69,0,1, +106.0000,off,77,0,0, +106.0000,on,70,100,0, +106.0000,on,67,100,1, +106.2500,off,65,0,2, +106.2500,on,65,100,2, +106.5000,off,65,0,2, +106.5000,on,64,100,2, +106.7500,off,67,0,1, +106.7500,off,64,0,2, +106.7500,on,65,100,1, +106.7500,on,62,100,2, +107.0000,off,65,0,1, +107.0000,off,62,0,2, +107.0000,on,64,100,1, +107.0000,on,61,100,2, +107.2500,off,70,0,0, +107.2500,on,70,100,0, +107.5000,off,70,0,0, +107.5000,on,69,100,0, +107.7500,off,69,0,0, +107.7500,on,67,100,0, +108.0000,off,61,0,2, +108.0000,off,67,0,0, +108.0000,on,65,100,0, +108.0000,on,62,100,2, +108.2500,off,62,0,2, +108.2500,on,60,100,2, +108.5000,off,64,0,1, +108.5000,off,60,0,2, +108.5000,on,62,100,1, +108.5000,on,58,100,2, +108.7500,off,62,0,1, +108.7500,off,58,0,2, +108.7500,on,61,100,1, +108.7500,on,57,100,2, +109.0000,off,65,0,0, +109.0000,off,61,0,1, +109.0000,off,57,0,2, +109.0000,on,70,100,0, +109.0000,on,62,100,1, +109.0000,on,55,100,2, +109.2500,off,55,0,2, +109.2500,on,57,100,2, +109.5000,off,62,0,1, +109.5000,off,57,0,2, +109.5000,on,67,100,1, +109.5000,on,58,100,2, +109.7500,off,58,0,2, +109.7500,on,60,100,2, +110.0000,off,70,0,0, +110.0000,off,60,0,2, +110.0000,on,69,100,0, +110.0000,on,62,100,2, +110.0000,on,50,100,3, +110.2500,off,62,0,2, +110.2500,on,57,100,2, +110.5000,off,57,0,2, +110.5000,on,62,100,2, +110.7500,off,67,0,1, +110.7500,on,65,100,1, +111.0000,off,50,0,3, +111.0000,off,65,0,1, +111.0000,on,64,100,1, +111.0000,on,57,100,3, +111.2500,off,62,0,2, +111.2500,on,59,100,2, +111.5000,off,69,0,0, +111.5000,off,59,0,2, +111.5000,on,76,100,0, +111.5000,on,61,100,2, +111.7500,off,64,0,1, +111.7500,on,64,100,1, +112.0000,off,57,0,3, +112.0000,off,64,0,1, +112.0000,on,69,100,1, +112.0000,on,53,100,3, +112.2500,off,76,0,0, +112.2500,off,61,0,2, +112.2500,on,73,100,0, +112.2500,on,64,100,2, +112.5000,off,73,0,0, +112.5000,off,64,0,2, +112.5000,on,74,100,0, +112.5000,on,57,100,2, +112.7500,off,74,0,0, +112.7500,off,57,0,2, +112.7500,on,76,100,0, +112.7500,on,61,100,2, +113.0000,off,53,0,3, +113.0000,off,76,0,0, +113.0000,off,61,0,2, +113.0000,on,77,100,0, +113.0000,on,62,100,2, +113.0000,on,50,100,3, +113.2500,off,77,0,0, +113.2500,on,74,100,0, +113.5000,off,69,0,1, +113.5000,off,62,0,2, +113.5000,off,74,0,0, +113.5000,on,79,100,0, +113.5000,on,67,100,1, +113.5000,on,58,100,2, +113.7500,off,67,0,1, +113.7500,off,58,0,2, +113.7500,on,70,100,1, +113.7500,on,55,100,2, +114.0000,off,50,0,3, +114.0000,off,70,0,1, +114.0000,off,55,0,2, +114.0000,on,69,100,1, +114.0000,on,52,100,2, +114.0000,on,49,100,3, +114.2500,off,79,0,0, +114.2500,on,76,100,0, +114.5000,off,76,0,0, +114.5000,on,81,100,0, +114.7500,off,81,0,0, +114.7500,on,79,100,0, +115.0000,off,52,0,2, +115.0000,off,49,0,3, +115.0000,off,79,0,0, +115.0000,on,77,100,0, +115.0000,on,53,100,2, +115.0000,on,50,100,3, +115.2500,off,69,0,1, +115.2500,off,77,0,0, +115.2500,on,76,100,0, +115.2500,on,67,100,1, +115.5000,off,53,0,2, +115.5000,off,50,0,3, +115.5000,off,76,0,0, +115.5000,off,67,0,1, +115.5000,on,74,100,0, +115.5000,on,65,100,1, +115.5000,on,55,100,2, +115.5000,on,52,100,3, +115.7500,off,74,0,0, +115.7500,off,65,0,1, +115.7500,on,73,100,0, +115.7500,on,64,100,1, +116.0000,off,55,0,2, +116.0000,off,52,0,3, +116.0000,off,73,0,0, +116.0000,off,64,0,1, +116.0000,on,74,100,0, +116.0000,on,62,100,1, +116.0000,on,57,100,2, +116.0000,on,53,100,3, +116.2500,off,74,0,0, +116.2500,on,72,100,0, +116.5000,off,72,0,0, +116.5000,on,70,100,0, +116.7500,off,70,0,0, +116.7500,on,69,100,0, +117.0000,off,57,0,2, +117.0000,off,69,0,0, +117.0000,on,67,100,0, +117.0000,on,59,100,2, +117.2500,off,53,0,3, +117.2500,on,55,100,3, +117.5000,off,62,0,1, +117.5000,off,59,0,2, +117.5000,off,55,0,3, +117.5000,on,64,100,1, +117.5000,on,61,100,2, +117.5000,on,53,100,3, +117.7500,off,53,0,3, +117.7500,on,52,100,3, +118.0000,off,64,0,1, +118.0000,off,61,0,2, +118.0000,off,52,0,3, +118.0000,on,57,100,1, +118.0000,on,62,100,2, +118.0000,on,50,100,3, +118.2500,off,67,0,0, +118.2500,on,64,100,0, +118.5000,off,57,0,1, +118.5000,off,62,0,2, +118.5000,off,64,0,0, +118.5000,on,65,100,0, +118.7500,off,65,0,0, +118.7500,on,62,100,0, +119.0000,off,62,0,0, +119.0000,on,69,100,0, +119.2500,off,50,0,3, +119.2500,on,51,100,3, +119.5000,off,51,0,3, +119.5000,on,63,100,1, +119.5000,on,54,100,2, +119.5000,on,50,100,3, +119.7500,off,50,0,3, +119.7500,on,48,100,3, +120.0000,off,63,0,1, +120.0000,off,54,0,2, +120.0000,off,48,0,3, +120.0000,on,62,100,1, +120.0000,on,55,100,2, +120.0000,on,46,100,3, +120.2500,off,69,0,0, +120.2500,off,55,0,2, +120.2500,on,66,100,0, +120.2500,on,57,100,2, +120.5000,off,66,0,0, +120.5000,off,57,0,2, +120.5000,on,67,100,0, +120.5000,on,58,100,2, +120.7500,off,67,0,0, +120.7500,on,70,100,0, +121.0000,off,62,0,1, +121.0000,off,58,0,2, +121.0000,off,70,0,0, +121.0000,on,72,100,0, +121.2500,off,46,0,3, +121.2500,on,48,100,3, +121.5000,off,48,0,3, +121.5000,on,66,100,1, +121.5000,on,60,100,2, +121.5000,on,46,100,3, +121.7500,off,46,0,3, +121.7500,on,45,100,3, +122.0000,off,66,0,1, +122.0000,off,60,0,2, +122.0000,off,45,0,3, +122.0000,on,67,100,1, +122.0000,on,62,100,2, +122.0000,on,43,100,3, +122.2500,off,72,0,0, +122.2500,off,67,0,1, +122.2500,on,69,100,0, +122.2500,on,66,100,1, +122.5000,off,69,0,0, +122.5000,off,66,0,1, +122.5000,on,70,100,0, +122.5000,on,67,100,1, +122.7500,off,70,0,0, +122.7500,on,74,100,0, +123.0000,off,62,0,2, +123.0000,off,67,0,1, +123.0000,off,74,0,0, +123.0000,on,75,100,0, +123.2500,on,55,100,2, +123.5000,off,43,0,3, +123.5000,off,75,0,0, +123.5000,on,74,100,0, +123.5000,on,70,100,1, +123.5000,on,43,100,3, +123.7500,off,55,0,2, +123.7500,on,53,100,2, +124.0000,off,74,0,0, +124.0000,off,53,0,2, +124.0000,on,73,100,0, +124.0000,on,52,100,2, +124.2500,off,70,0,1, +124.2500,on,69,100,1, +124.5000,off,73,0,0, +124.5000,off,69,0,1, +124.5000,on,81,100,0, +124.5000,on,77,100,1, +124.7500,off,77,0,1, +124.7500,on,74,100,1, +125.0000,off,52,0,2, +125.0000,off,74,0,1, +125.0000,on,71,100,1, +125.2500,off,81,0,0, +125.2500,on,74,100,0, +125.5000,off,71,0,1, +125.5000,off,74,0,0, +125.5000,on,79,100,0, +125.5000,on,76,100,1, +125.7500,off,76,0,1, +125.7500,on,73,100,1, +126.0000,off,73,0,1, +126.0000,on,69,100,1, +126.2500,off,79,0,0, +126.2500,on,73,100,0, +126.5000,off,69,0,1, +126.5000,off,73,0,0, +126.5000,on,77,100,0, +126.5000,on,74,100,1, +126.5000,on,53,100,2, +126.7500,off,74,0,1, +126.7500,off,53,0,2, +126.7500,on,69,100,1, +126.7500,on,50,100,2, +127.0000,off,69,0,1, +127.0000,off,50,0,2, +127.0000,on,70,100,1, +127.0000,on,55,100,2, +127.2500,off,77,0,0, +127.2500,on,74,100,0, +127.5000,off,74,0,0, +127.5000,on,76,100,0, +127.7500,off,70,0,1, +127.7500,off,55,0,2, +127.7500,on,67,100,1, +127.7500,on,49,100,2, +128.0000,off,67,0,1, +128.0000,off,49,0,2, +128.0000,on,69,100,1, +128.0000,on,53,100,2, +128.2500,off,76,0,0, +128.2500,on,73,100,0, +128.5000,off,73,0,0, +128.5000,on,74,100,0, +128.7500,off,69,0,1, +128.7500,off,53,0,2, +128.7500,on,65,100,1, +128.7500,on,50,100,2, +129.0000,off,65,0,1, +129.0000,off,50,0,2, +129.0000,on,64,100,1, +129.0000,on,57,100,2, +129.2500,off,74,0,0, +129.2500,on,71,100,0, +129.5000,off,43,0,3, +129.5000,off,71,0,0, +129.5000,on,72,100,0, +129.5000,on,45,100,3, +129.7500,off,64,0,1, +129.7500,on,67,100,1, +130.0000,off,57,0,2, +130.0000,off,45,0,3, +130.0000,off,67,0,1, +130.0000,on,66,100,1, +130.0000,on,50,100,2, +130.0000,on,46,100,3, +130.2500,off,66,0,1, +130.2500,on,62,100,1, +130.5000,off,72,0,0, +130.5000,off,50,0,2, +130.5000,off,62,0,1, +130.5000,on,70,100,0, +130.5000,on,67,100,1, +130.5000,on,62,100,2, +130.7500,off,46,0,3, +130.7500,on,43,100,3, +131.0000,off,70,0,0, +131.0000,off,43,0,3, +131.0000,on,69,100,0, +131.0000,on,50,100,3, +131.2500,off,67,0,1, +131.2500,on,64,100,1, +131.5000,off,62,0,2, +131.5000,off,64,0,1, +131.5000,on,65,100,1, +131.5000,on,57,100,2, +131.7500,off,69,0,0, +131.7500,off,57,0,2, +131.7500,on,69,100,0, +131.7500,on,53,100,2, +132.0000,off,69,0,0, +132.0000,off,53,0,2, +132.0000,on,74,100,0, +132.0000,on,58,100,2, +132.2500,off,50,0,3, +132.2500,off,65,0,1, +132.2500,off,74,0,0, +132.2500,on,77,100,0, +132.2500,on,74,100,1, +132.2500,on,46,100,3, +132.5000,off,77,0,0, +132.5000,off,74,0,1, +132.5000,off,46,0,3, +132.5000,on,76,100,0, +132.5000,on,72,100,1, +132.5000,on,48,100,3, +132.7500,off,76,0,0, +132.7500,on,79,100,0, +133.0000,off,48,0,3, +133.0000,off,79,0,0, +133.0000,on,77,100,0, +133.0000,on,53,100,3, +133.2500,off,58,0,2, +133.2500,off,77,0,0, +133.2500,on,76,100,0, +133.2500,on,56,100,2, +133.5000,off,76,0,0, +133.5000,off,56,0,2, +133.5000,on,74,100,0, +133.5000,on,57,100,2, +133.7500,off,72,0,1, +133.7500,on,72,100,1, +134.0000,off,57,0,2, +134.0000,off,72,0,1, +134.0000,on,70,100,1, +134.0000,on,62,100,2, +134.2500,off,53,0,3, +134.2500,off,74,0,0, +134.2500,off,70,0,1, +134.2500,on,77,100,0, +134.2500,on,69,100,1, +134.2500,on,50,100,3, +134.5000,off,69,0,1, +134.5000,off,50,0,3, +134.5000,on,68,100,1, +134.5000,on,52,100,3, +134.7500,off,77,0,0, +134.7500,on,76,100,0, +135.0000,off,68,0,1, +135.0000,off,52,0,3, +135.0000,off,76,0,0, +135.0000,on,77,100,0, +135.0000,on,69,100,1, +135.0000,on,57,100,3, +135.2500,off,62,0,2, +135.2500,off,77,0,0, +135.2500,on,74,100,0, +135.2500,on,59,100,2, +135.5000,off,74,0,0, +135.5000,off,59,0,2, +135.5000,on,76,100,0, +135.5000,on,60,100,2, +135.7500,off,69,0,1, +135.7500,on,64,100,1, +136.0000,off,60,0,2, +136.0000,off,64,0,1, +136.0000,on,69,100,1, +136.0000,on,65,100,2, +136.2500,off,57,0,3, +136.2500,off,76,0,0, +136.2500,on,74,100,0, +136.2500,on,53,100,3, +136.5000,off,69,0,1, +136.5000,off,74,0,0, +136.5000,off,53,0,3, +136.5000,on,72,100,0, +136.5000,on,67,100,1, +136.5000,on,55,100,3, +136.7500,off,72,0,0, +136.7500,on,71,100,0, +137.0000,off,55,0,3, +137.0000,off,71,0,0, +137.0000,on,72,100,0, +137.0000,on,60,100,3, +137.2500,off,65,0,2, +137.2500,on,62,100,2, +137.5000,off,62,0,2, +137.5000,on,63,100,2, +137.7500,off,67,0,1, +137.7500,off,72,0,0, +137.7500,on,81,100,0, +137.7500,on,72,100,1, +138.0000,off,63,0,2, +138.0000,off,81,0,0, +138.0000,off,72,0,1, +138.0000,on,79,100,0, +138.0000,on,69,100,1, +138.0000,on,62,100,2, +138.2500,off,60,0,3, +138.2500,off,79,0,0, +138.2500,on,78,100,0, +138.2500,on,57,100,3, +138.5000,off,69,0,1, +138.5000,off,78,0,0, +138.5000,off,57,0,3, +138.5000,on,79,100,0, +138.5000,on,67,100,1, +138.5000,on,58,100,3, +138.7500,off,79,0,0, +138.7500,on,82,100,0, +139.0000,off,62,0,2, +139.0000,off,82,0,0, +139.0000,on,73,100,0, +139.0000,on,64,100,2, +139.5000,off,67,0,1, +139.5000,off,58,0,3, +139.5000,off,73,0,0, +139.5000,off,64,0,2, +141.0000,on,74,100,0, +141.0000,on,69,100,1, +141.0000,on,65,100,2, +141.0000,on,57,100,3, +141.5000,off,74,0,0, +141.5000,off,69,0,1, +141.5000,off,65,0,2, +141.5000,off,57,0,3, +143.0000,on,74,100,0, +143.0000,on,71,100,1, +143.0000,on,65,100,2, +143.0000,on,56,100,3, +144.0000,off,71,0,1, +144.0000,off,56,0,3, +144.0000,on,69,100,1, +144.0000,on,57,100,3, +144.5000,off,65,0,2, +144.5000,on,64,100,2, +144.7500,off,64,0,2, +144.7500,on,62,100,2, +145.0000,off,62,0,2, +145.0000,on,64,100,2, +145.2500,off,74,0,0, +145.2500,on,71,100,0, +145.5000,off,57,0,3, +145.5000,off,64,0,2, +145.5000,off,71,0,0, +145.5000,on,73,100,0, +145.5000,on,45,100,3, +145.7500,off,69,0,1, +145.7500,on,67,100,1, +146.0000,off,73,0,0, +146.0000,off,45,0,3, +146.0000,off,67,0,1, +146.0000,on,74,100,0, +146.0000,on,66,100,1, +146.0000,on,57,100,2, +146.0000,on,50,100,3, +146.2500,off,66,0,1, +146.2500,on,67,100,1, +146.5000,off,67,0,1, +146.5000,on,69,100,1, +146.7500,off,74,0,0, +146.7500,on,72,100,0, +147.0000,off,57,0,2, +147.0000,off,72,0,0, +147.0000,on,70,100,0, +147.0000,on,62,100,2, +147.2500,off,69,0,1, +147.2500,on,67,100,1, +147.5000,off,67,0,1, +147.5000,on,72,100,1, +147.7500,off,70,0,0, +147.7500,on,69,100,0, +148.0000,off,62,0,2, +148.0000,off,69,0,0, +148.0000,on,62,100,0, +148.0000,on,58,100,2, +148.2500,off,72,0,1, +148.2500,on,66,100,1, +148.5000,off,66,0,1, +148.5000,on,67,100,1, +148.7500,off,67,0,1, +148.7500,on,70,100,1, +149.0000,off,62,0,0, +149.0000,off,58,0,2, +149.0000,off,70,0,1, +149.0000,on,63,100,1, +149.0000,on,55,100,2, +149.2500,on,67,100,0, +149.5000,off,67,0,0, +149.5000,on,69,100,0, +149.7500,off,69,0,0, +149.7500,on,72,100,0, +150.0000,off,63,0,1, +150.0000,off,55,0,2, +150.0000,on,62,100,1, +150.0000,on,54,100,2, +150.2500,off,72,0,0, +150.2500,on,70,100,0, +150.5000,off,62,0,1, +150.5000,off,70,0,0, +150.5000,on,72,100,0, +150.5000,on,57,100,1, +150.7500,off,72,0,0, +150.7500,on,75,100,0, +151.0000,off,54,0,2, +151.0000,off,57,0,1, +151.0000,on,58,100,1, +151.0000,on,55,100,2, +151.2500,off,75,0,0, +151.2500,on,74,100,0, +151.5000,off,58,0,1, +151.5000,off,55,0,2, +151.5000,off,74,0,0, +151.5000,on,78,100,0, +151.5000,on,60,100,1, +151.5000,on,57,100,2, +151.7500,off,78,0,0, +151.7500,on,81,100,0, +152.0000,off,60,0,1, +152.0000,off,57,0,2, +152.0000,on,62,100,1, +152.0000,on,58,100,2, +152.2500,off,81,0,0, +152.2500,on,79,100,0, +152.3750,off,79,0,0, +152.3750,on,81,100,0, +152.5000,off,62,0,1, +152.5000,off,81,0,0, +152.5000,on,82,100,0, +152.5000,on,55,100,1, +152.7500,off,82,0,0, +152.7500,on,73,100,0, +153.0000,off,73,0,0, +153.0000,on,74,100,0, +153.2500,off,58,0,2, +153.2500,off,55,0,1, +153.2500,on,70,100,1, +153.2500,on,62,100,2, +153.5000,off,70,0,1, +153.5000,off,62,0,2, +153.5000,on,69,100,1, +153.5000,on,60,100,2, +153.7500,off,69,0,1, +153.7500,off,60,0,2, +153.7500,on,67,100,1, +153.7500,on,58,100,2, +154.0000,off,58,0,2, +154.0000,on,57,100,2, +154.2500,off,67,0,1, +154.2500,on,66,100,1, +154.5000,off,57,0,2, +154.5000,off,66,0,1, +154.5000,on,64,100,1, +154.5000,on,57,100,2, +154.7500,off,64,0,1, +154.7500,on,67,100,1, +155.0000,off,67,0,1, +155.0000,on,66,100,1, +156.0000,off,50,0,3, +156.0000,off,74,0,0, +156.0000,off,57,0,2, +156.0000,off,66,0,1, diff --git a/data/csv/mnd/all-notes-off.csv b/data/csv/mnd/all-notes-off.csv new file mode 100644 --- /dev/null +++ b/data/csv/mnd/all-notes-off.csv @@ -0,0 +1,129 @@ +time,on/off,note,velocity,channel,param +0.0000,off,0,0,0, +0.0100,off,1,0,0, +0.0200,off,2,0,0, +0.0300,off,3,0,0, +0.0400,off,4,0,0, +0.0500,off,5,0,0, +0.0600,off,6,0,0, +0.0700,off,7,0,0, +0.0800,off,8,0,0, +0.0900,off,9,0,0, +0.1000,off,10,0,0, +0.1100,off,11,0,0, +0.1200,off,12,0,0, +0.1300,off,13,0,0, +0.1400,off,14,0,0, +0.1500,off,15,0,0, +0.1600,off,16,0,0, +0.1700,off,17,0,0, +0.1800,off,18,0,0, +0.1900,off,19,0,0, +0.2000,off,20,0,0, +0.2100,off,21,0,0, +0.2200,off,22,0,0, +0.2300,off,23,0,0, +0.2400,off,24,0,0, +0.2500,off,25,0,0, +0.2600,off,26,0,0, +0.2700,off,27,0,0, +0.2800,off,28,0,0, +0.2900,off,29,0,0, +0.3000,off,30,0,0, +0.3100,off,31,0,0, +0.3200,off,32,0,0, +0.3300,off,33,0,0, +0.3400,off,34,0,0, +0.3500,off,35,0,0, +0.3600,off,36,0,0, +0.3700,off,37,0,0, +0.3800,off,38,0,0, +0.3900,off,39,0,0, +0.4000,off,40,0,0, +0.4100,off,41,0,0, +0.4200,off,42,0,0, +0.4300,off,43,0,0, +0.4400,off,44,0,0, +0.4500,off,45,0,0, +0.4600,off,46,0,0, +0.4700,off,47,0,0, +0.4800,off,48,0,0, +0.4900,off,49,0,0, +0.5000,off,50,0,0, +0.5100,off,51,0,0, +0.5200,off,52,0,0, +0.5300,off,53,0,0, +0.5400,off,54,0,0, +0.5500,off,55,0,0, +0.5600,off,56,0,0, +0.5700,off,57,0,0, +0.5800,off,58,0,0, +0.5900,off,59,0,0, +0.6000,off,60,0,0, +0.6100,off,61,0,0, +0.6200,off,62,0,0, +0.6300,off,63,0,0, +0.6400,off,64,0,0, +0.6500,off,65,0,0, +0.6600,off,66,0,0, +0.6700,off,67,0,0, +0.6800,off,68,0,0, +0.6900,off,69,0,0, +0.7000,off,70,0,0, +0.7100,off,71,0,0, +0.7200,off,72,0,0, +0.7300,off,73,0,0, +0.7400,off,74,0,0, +0.7500,off,75,0,0, +0.7600,off,76,0,0, +0.7700,off,77,0,0, +0.7800,off,78,0,0, +0.7900,off,79,0,0, +0.8000,off,80,0,0, +0.8100,off,81,0,0, +0.8200,off,82,0,0, +0.8300,off,83,0,0, +0.8400,off,84,0,0, +0.8500,off,85,0,0, +0.8600,off,86,0,0, +0.8700,off,87,0,0, +0.8800,off,88,0,0, +0.8900,off,89,0,0, +0.9000,off,90,0,0, +0.9100,off,91,0,0, +0.9200,off,92,0,0, +0.9300,off,93,0,0, +0.9400,off,94,0,0, +0.9500,off,95,0,0, +0.9600,off,96,0,0, +0.9700,off,97,0,0, +0.9800,off,98,0,0, +0.9900,off,99,0,0, +1.0000,off,100,0,0, +1.0100,off,101,0,0, +1.0200,off,102,0,0, +1.0300,off,103,0,0, +1.0400,off,104,0,0, +1.0500,off,105,0,0, +1.0600,off,106,0,0, +1.0700,off,107,0,0, +1.0800,off,108,0,0, +1.0900,off,109,0,0, +1.1000,off,110,0,0, +1.1100,off,111,0,0, +1.1200,off,112,0,0, +1.1300,off,113,0,0, +1.1400,off,114,0,0, +1.1500,off,115,0,0, +1.1600,off,116,0,0, +1.1700,off,117,0,0, +1.1800,off,118,0,0, +1.1900,off,119,0,0, +1.2000,off,120,0,0, +1.2100,off,121,0,0, +1.2200,off,122,0,0, +1.2300,off,123,0,0, +1.2400,off,124,0,0, +1.2500,off,125,0,0, +1.2600,off,126,0,0, +1.2700,off,127,0,0, diff --git a/data/dot/euler/euler-j5-a.dot b/data/dot/euler/euler-j5-a.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-j5-a.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_3 [label="A♮\n5:3"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_16_9 [label="B♭\n16:9"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_64_45 [label="F♯\n64:45"]; +R_16_15 [label="C♯\n16:15"]; +R_8_5 [label="A♭\n8:5"]; +R_6_5 [label="E♭\n6:5"]; +R_5_3 -- R_5_4 -- R_15_8; +R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8; +R_64_45 -- R_16_15 -- R_8_5 -- R_6_5; +R_4_3 -- R_5_3 [label=" (8:5)"]; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_64_45 -- R_16_9 [label=" (8:5)"]; +R_16_15 -- R_4_3 [label=" (8:5)"]; +R_8_5 -- R_1_1 [label=" (8:5)"]; +R_6_5 -- R_3_2 [label=" (8:5)"]; +{rank=min; R_5_3 R_5_4 R_15_8} +{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8} +{rank=max; R_64_45 R_16_15 R_8_5 R_6_5} +} diff --git a/data/dot/euler/euler-j5-b.dot b/data/dot/euler/euler-j5-b.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-j5-b.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_3 [label="A♮\n5:3"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_45_32 [label="F♯\n45:32"]; +R_16_9 [label="B♭\n16:9"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_16_15 [label="C♯\n16:15"]; +R_8_5 [label="A♭\n8:5"]; +R_6_5 [label="E♭\n6:5"]; +R_5_3 -- R_5_4 -- R_15_8 -- R_45_32; +R_16_9 -- R_4_3 -- R_1_1 -- R_3_2 -- R_9_8; +R_16_15 -- R_8_5 -- R_6_5; +R_4_3 -- R_5_3 [label=" (8:5)"]; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_9_8 -- R_45_32 [label=" (8:5)"]; +R_16_15 -- R_4_3 [label=" (8:5)"]; +R_8_5 -- R_1_1 [label=" (8:5)"]; +R_6_5 -- R_3_2 [label=" (8:5)"]; +{rank=min; R_5_3 R_5_4 R_15_8 R_45_32} +{rank=same; R_16_9 R_4_3 R_1_1 R_3_2 R_9_8} +{rank=max; R_16_15 R_8_5 R_6_5} +} diff --git a/data/dot/euler/euler-j7.dot b/data/dot/euler/euler-j7.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-j7.dot @@ -0,0 +1,29 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_5_4 [label="E♮\n5:4"]; +R_15_8 [label="B♮\n15:8"]; +R_45_32 [label="F♯\n45:32"]; +R_135_128 [label="C♯\n135:128"]; +R_4_3 [label="F♮\n4:3"]; +R_1_1 [label="C♮\n1:1"]; +R_3_2 [label="G♮\n3:2"]; +R_9_8 [label="D♮\n9:8"]; +R_27_16 [label="A♮\n27:16"]; +R_14_9 [label="A♭\n14:9"]; +R_7_6 [label="E♭\n7:6"]; +R_7_4 [label="B♭\n7:4"]; +R_5_4 -- R_15_8 -- R_45_32 -- R_135_128; +R_4_3 -- R_1_1 -- R_3_2 -- R_9_8 -- R_27_16; +R_14_9 -- R_7_6 -- R_7_4; +R_1_1 -- R_5_4 [label=" (8:5)"]; +R_3_2 -- R_15_8 [label=" (8:5)"]; +R_9_8 -- R_45_32 [label=" (8:5)"]; +R_27_16 -- R_135_128 [label=" (8:5)"]; +R_7_6 -- R_4_3 [label=" (7:4)"]; +R_7_4 -- R_1_1 [label=" (7:4)"]; +{rank=min; R_5_4 R_15_8 R_45_32 R_135_128} +{rank=same; R_4_3 R_1_1 R_3_2 R_9_8 R_27_16} +{rank=max; R_14_9 R_7_6 R_7_4} +} diff --git a/data/dot/euler/euler-wtp.dot b/data/dot/euler/euler-wtp.dot new file mode 100644 --- /dev/null +++ b/data/dot/euler/euler-wtp.dot @@ -0,0 +1,30 @@ +graph g { +graph [layout="dot",rankdir="TB",nodesep=0.5]; +edge [fontsize="8",fontname="century schoolbook"]; +node [shape="plaintext",fontsize="10",fontname="century schoolbook"]; +R_49_32 [label="B♭=738\n49:32"]; +R_147_128 [label="F♮=240\n147:128"]; +R_441_256 [label="C♮=942\n441:256"]; +R_1323_1024 [label="G♮=444\n1323:1024"]; +R_7_4 [label="C♯=969\n7:4"]; +R_21_16 [label="A♭=471\n21:16"]; +R_63_32 [label="E♭=1173\n63:32"]; +R_189_128 [label="B♭=675\n189:128"]; +R_567_512 [label="F♮=177\n567:512"]; +R_1_1 [label="E♭=0\n1:1"]; +R_3_2 [label="B♭=702\n3:2"]; +R_9_8 [label="F♮=204\n9:8"]; +R_49_32 -- R_147_128 -- R_441_256 -- R_1323_1024; +R_7_4 -- R_21_16 -- R_63_32 -- R_189_128 -- R_567_512; +R_1_1 -- R_3_2 -- R_9_8; +R_7_4 -- R_49_32 [label=" (8:7)"]; +R_21_16 -- R_147_128 [label=" (8:7)"]; +R_63_32 -- R_441_256 [label=" (8:7)"]; +R_189_128 -- R_1323_1024 [label=" (8:7)"]; +R_1_1 -- R_7_4 [label=" (8:7)"]; +R_3_2 -- R_21_16 [label=" (8:7)"]; +R_9_8 -- R_63_32 [label=" (8:7)"]; +{rank=min; R_49_32 R_147_128 R_441_256 R_1323_1024} +{rank=same; R_7_4 R_21_16 R_63_32 R_189_128 R_567_512} +{rank=max; R_1_1 R_3_2 R_9_8} +} diff --git a/data/scl/et12.scl b/data/scl/et12.scl new file mode 100644 --- /dev/null +++ b/data/scl/et12.scl @@ -0,0 +1,17 @@ +! et12.scl +! +12 tone equal temperament +12 +! +100.0 +200.0 +300.0 +400.0 +500.0 +600.0 +700.0 +800.0 +900.0 +1000.0 +1100.0 +2/1 diff --git a/data/scl/et19.scl b/data/scl/et19.scl new file mode 100644 --- /dev/null +++ b/data/scl/et19.scl @@ -0,0 +1,24 @@ +! et19.scl +! +19 tone equal temperament +19 +! +63.1578947368421 +126.3157894736842 +189.4736842105263 +252.63157894736838 +315.78947368421046 +378.94736842105254 +442.1052631578946 +505.2631578947367 +568.4210526315787 +631.5789473684208 +694.7368421052629 +757.894736842105 +821.0526315789471 +884.2105263157891 +947.3684210526312 +1010.5263157894733 +1073.6842105263154 +1136.8421052631575 +2/1 diff --git a/data/scl/et31.scl b/data/scl/et31.scl new file mode 100644 --- /dev/null +++ b/data/scl/et31.scl @@ -0,0 +1,36 @@ +! et31.scl +! +31 tone equal temperament +31 +! +38.70967741935484 +77.41935483870968 +116.12903225806451 +154.83870967741933 +193.54838709677415 +232.25806451612897 +270.9677419354838 +309.6774193548386 +348.3870967741934 +387.09677419354824 +425.80645161290306 +464.5161290322579 +503.2258064516127 +541.9354838709676 +580.6451612903224 +619.3548387096773 +658.0645161290322 +696.7741935483871 +735.483870967742 +774.1935483870968 +812.9032258064517 +851.6129032258066 +890.3225806451615 +929.0322580645163 +967.7419354838712 +1006.4516129032261 +1045.161290322581 +1083.8709677419358 +1122.5806451612907 +1161.2903225806456 +2/1 diff --git a/data/scl/et53.scl b/data/scl/et53.scl new file mode 100644 --- /dev/null +++ b/data/scl/et53.scl @@ -0,0 +1,58 @@ +! et53.scl +! +53 tone equal temperament +53 +! +22.641509433962263 +45.283018867924525 +67.9245283018868 +90.56603773584906 +113.20754716981133 +135.8490566037736 +158.49056603773585 +181.1320754716981 +203.77358490566036 +226.4150943396226 +249.05660377358487 +271.6981132075471 +294.3396226415094 +316.98113207547163 +339.6226415094339 +362.26415094339615 +384.9056603773584 +407.54716981132066 +430.1886792452829 +452.83018867924517 +475.4716981132074 +498.1132075471697 +520.7547169811319 +543.3962264150941 +566.0377358490564 +588.6792452830186 +611.3207547169809 +633.9622641509432 +656.6037735849054 +679.2452830188677 +701.8867924528299 +724.5283018867922 +747.1698113207544 +769.8113207547167 +792.452830188679 +815.0943396226412 +837.7358490566035 +860.3773584905657 +883.018867924528 +905.6603773584902 +928.3018867924525 +950.9433962264147 +973.584905660377 +996.2264150943392 +1018.8679245283015 +1041.5094339622638 +1064.150943396226 +1086.7924528301883 +1109.4339622641505 +1132.0754716981128 +1154.716981132075 +1177.3584905660373 +2/1 diff --git a/data/scl/et72.scl b/data/scl/et72.scl new file mode 100644 --- /dev/null +++ b/data/scl/et72.scl @@ -0,0 +1,77 @@ +! et72.scl +! +72 tone equal temperament +72 +! +16.666666666666668 +33.333333333333336 +50.0 +66.66666666666666 +83.33333333333331 +99.99999999999997 +116.66666666666663 +133.3333333333333 +149.99999999999994 +166.6666666666666 +183.33333333333326 +199.99999999999991 +216.66666666666657 +233.33333333333323 +249.9999999999999 +266.6666666666665 +283.33333333333314 +299.9999999999998 +316.6666666666664 +333.33333333333303 +349.99999999999966 +366.6666666666663 +383.3333333333329 +399.99999999999955 +416.6666666666662 +433.3333333333328 +449.99999999999943 +466.66666666666606 +483.3333333333327 +499.9999999999993 +516.666666666666 +533.3333333333326 +549.9999999999992 +566.6666666666658 +583.3333333333325 +599.9999999999991 +616.6666666666657 +633.3333333333323 +649.999999999999 +666.6666666666656 +683.3333333333322 +699.9999999999989 +716.6666666666655 +733.3333333333321 +749.9999999999987 +766.6666666666654 +783.333333333332 +799.9999999999986 +816.6666666666653 +833.3333333333319 +849.9999999999985 +866.6666666666652 +883.3333333333318 +899.9999999999984 +916.666666666665 +933.3333333333317 +949.9999999999983 +966.6666666666649 +983.3333333333316 +999.9999999999982 +1016.6666666666648 +1033.3333333333314 +1049.9999999999982 +1066.666666666665 +1083.3333333333317 +1099.9999999999984 +1116.6666666666652 +1133.333333333332 +1149.9999999999986 +1166.6666666666654 +1183.3333333333321 +2/1 diff --git a/data/scl/et96.scl b/data/scl/et96.scl new file mode 100644 --- /dev/null +++ b/data/scl/et96.scl @@ -0,0 +1,101 @@ +! et96.scl +! +96 tone equal temperament +96 +! +12.5 +25.0 +37.5 +50.0 +62.5 +75.0 +87.5 +100.0 +112.5 +125.0 +137.5 +150.0 +162.5 +175.0 +187.5 +200.0 +212.5 +225.0 +237.5 +250.0 +262.5 +275.0 +287.5 +300.0 +312.5 +325.0 +337.5 +350.0 +362.5 +375.0 +387.5 +400.0 +412.5 +425.0 +437.5 +450.0 +462.5 +475.0 +487.5 +500.0 +512.5 +525.0 +537.5 +550.0 +562.5 +575.0 +587.5 +600.0 +612.5 +625.0 +637.5 +650.0 +662.5 +675.0 +687.5 +700.0 +712.5 +725.0 +737.5 +750.0 +762.5 +775.0 +787.5 +800.0 +812.5 +825.0 +837.5 +850.0 +862.5 +875.0 +887.5 +900.0 +912.5 +925.0 +937.5 +950.0 +962.5 +975.0 +987.5 +1000.0 +1012.5 +1025.0 +1037.5 +1050.0 +1062.5 +1075.0 +1087.5 +1100.0 +1112.5 +1125.0 +1137.5 +1150.0 +1162.5 +1175.0 +1187.5 +2/1 diff --git a/data/scl/ew_1357_3.scl b/data/scl/ew_1357_3.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_1357_3.scl @@ -0,0 +1,28 @@ +! ew_1357_3.scl +! +EW, 1-3-5-7-9Genus.pdf, P.3 +23 +! +81/80 +21/20 +35/32 +9/8 +7/6 +189/160 +5/4 +81/64 +21/16 +27/20 +45/32 +35/24 +3/2 +243/160 +63/40 +5/3 +27/16 +7/4 +567/320 +15/8 +35/18 +63/32 +2/1 diff --git a/data/scl/ew_Pelogflute_2.scl b/data/scl/ew_Pelogflute_2.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_Pelogflute_2.scl @@ -0,0 +1,14 @@ +! ew_Pelogflute_2.scl +! +EW, Pelogflute.pdf, P.2 +9 +! +16/15 +64/55 +5/4 +4/3 +16/11 +8/5 +128/75 +20/11 +2/1 diff --git a/data/scl/ew_el12_12.scl b/data/scl/ew_el12_12.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_el12_12.scl @@ -0,0 +1,17 @@ +! ew_el12_12.scl +! +EW, earlylattices12.pdf, P.12 +12 +! +45/44 +12/11 +7/6 +5/4 +14/11 +15/11 +35/24 +14/9 +35/22 +56/33 +15/8 +2/1 diff --git a/data/scl/ew_el12_7.scl b/data/scl/ew_el12_7.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_el12_7.scl @@ -0,0 +1,17 @@ +! ew_el12_7.scl +! +EW, earlylattices12.pdf, P.7 +12 +! +80/77 +8/7 +77/64 +847/640 +11/8 +10/7 +16/11 +847/512 +128/77 +121/64 +77/40 +2/1 diff --git a/data/scl/ew_hel_12.scl b/data/scl/ew_hel_12.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_hel_12.scl @@ -0,0 +1,27 @@ +! ew_hel_12.scl +! +EW, hel.pdf, P.12 +22 +! +135/128 +13/12 +10/9 +9/8 +7/6 +11/9 +5/4 +81/64 +4/3 +11/8 +45/32 +17/12 +3/2 +405/256 +13/8 +5/3 +27/16 +7/4 +11/6 +15/8 +23/12 +2/1 diff --git a/data/scl/ew_novarotreediamond_1.scl b/data/scl/ew_novarotreediamond_1.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_novarotreediamond_1.scl @@ -0,0 +1,28 @@ +! ew_novarotreediamond_1.scl +! +EW, novavotreediamond.pdf, P.1 +23 +! +21/20 +16/15 +10/9 +9/8 +8/7 +7/6 +6/5 +5/4 +21/16 +4/3 +7/5 +10/7 +3/2 +32/21 +8/5 +5/3 +12/7 +7/4 +16/9 +9/5 +15/8 +40/21 +2/1 diff --git a/data/scl/ew_poole.scl b/data/scl/ew_poole.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_poole.scl @@ -0,0 +1,27 @@ +! ew_poole.scl +! +EW, 2010/10/scale-for-rod-poole.html +22 +! +33/32 +21/20 +13/12 +9/8 +7/6 +11/9 +5/4 +14/11 +4/3 +11/8 +7/5 +13/9 +3/2 +14/9 +44/27 +5/3 +27/16 +7/4 +11/6 +15/8 +21/11 +2/1 diff --git a/data/scl/ew_two_22_7.scl b/data/scl/ew_two_22_7.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_two_22_7.scl @@ -0,0 +1,27 @@ +! ew_two_22_7.scl +! +EW, 2018/03/an-unusual-22-tone-7-limit-tuning.html +22 +! +36/35 +16/15 +35/32 +9/8 +7/6 +6/5 +315/256 +245/192 +21/16 +27/20 +7/5 +735/512 +189/128 +49/32 +63/40 +5/3 +12/7 +16/9 +64/35 +15/8 +35/18 +2/1 diff --git a/data/scl/ew_xen3b_3.scl b/data/scl/ew_xen3b_3.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_xen3b_3.scl @@ -0,0 +1,22 @@ +! ew_xen3b_3.scl +! +EW, xen3b.pdf, P.3 +17 +! +256/243 +12/11 +9/8 +32/27 +5/4 +81/64 +4/3 +1024/729 +16/11 +3/2 +128/81 +5/3 +27/16 +16/9 +15/8 +243/128 +2/1 diff --git a/data/scl/ew_xen456_9.scl b/data/scl/ew_xen456_9.scl new file mode 100644 --- /dev/null +++ b/data/scl/ew_xen456_9.scl @@ -0,0 +1,24 @@ +! ew_xen456_9.scl +! +EW, xen456.pdf, P.9 +19 +! +45/44 +16/15 +12/11 +8/7 +32/27 +40/33 +14/11 +4/3 +15/11 +64/45 +16/11 +32/21 +8/5 +18/11 +12/7 +16/9 +20/11 +21/11 +2/1 diff --git a/data/scl/young-lm_piano_1964.scl b/data/scl/young-lm_piano_1964.scl new file mode 100644 --- /dev/null +++ b/data/scl/young-lm_piano_1964.scl @@ -0,0 +1,17 @@ +! young-lm_piano_1964.scl +! +LaMonte Young's Well-Tuned Piano (1964) +12 +! +279/256 +9/8 +147/128 +21/16 +93/64 +189/128 +3/2 +49/32 +7/4 +31/16 +63/32 +2/1 diff --git a/hmt.cabal b/hmt.cabal --- a/hmt.cabal +++ b/hmt.cabal @@ -1,81 +1,110 @@ +cabal-version: 2.4 Name: hmt -Version: 0.15 +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-2014 +Copyright: Rohan Drape, 2006-2022 Author: Rohan Drape -Maintainer: rd@slavepianos.org +Maintainer: rd@rohandrape.net Stability: Experimental -Homepage: http://rd.slavepianos.org/t/hmt -Tested-With: GHC == 7.8.2 +Homepage: http://rohandrape.net/t/hmt +Tested-With: GHC == 9.2.4 Build-Type: Simple -Cabal-Version: >= 1.8 -Data-files: README - Help/hmt.help.lhs +Data-files: README.md + data/csv/mnd/*.csv + data/dot/euler/*.dot + data/scl/*.scl Library Build-Depends: array, - base == 4.*, + base >= 4.9 && < 5, bytestring, colour, containers, + data-memocombinators, data-ordlist, directory, + fgl, filepath, + hmt-base == 0.20.*, lazy-csv, logict, multiset-comb, parsec, - permutation, primes, + process, + random, safe, split, - utf8-string + strict, + text, + time + Default-Language:Haskell2010 GHC-Options: -Wall -fwarn-tabs - Exposed-modules: Music.Theory.Array.CSV - Music.Theory.Array.CSV.Midi - Music.Theory.Array.MD + 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.Square Music.Theory.Bjorklund Music.Theory.Block_Design.Johnson_2007 + Music.Theory.Braille Music.Theory.Clef - Music.Theory.Combinations Music.Theory.Contour.Polansky_1992 + 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.Function + Music.Theory.Gamelan + Music.Theory.Graph.Deacon_1934 + Music.Theory.Graph.Dot + Music.Theory.Graph.Fgl + Music.Theory.Graph.Johnson_2014 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.Key - Music.Theory.List - Music.Theory.Math - Music.Theory.Maybe + Music.Theory.List.Logic + Music.Theory.Math.Convert.Fx + Music.Theory.Math.Nichomachus + Music.Theory.Math.Oeis + Music.Theory.Math.Prime Music.Theory.Meter.Barlow_1987 Music.Theory.Metric.Buchler_1998 Music.Theory.Metric.Morris_1980 Music.Theory.Metric.Polansky_1996 - Music.Theory.Permutations + Music.Theory.Parse Music.Theory.Permutations.List Music.Theory.Permutations.Morris_1984 Music.Theory.Pitch + Music.Theory.Pitch.Bark + Music.Theory.Pitch.Chord Music.Theory.Pitch.Name Music.Theory.Pitch.Note + Music.Theory.Pitch.Note.Name Music.Theory.Pitch.Spelling Music.Theory.Pitch.Spelling.Cluster + Music.Theory.Pitch.Spelling.Key + Music.Theory.Pitch.Spelling.Table + Music.Theory.Random.I_Ching + Music.Theory.Random.Jones_1981 Music.Theory.Set.List Music.Theory.Set.Set Music.Theory.Tempo_Marking @@ -83,47 +112,66 @@ 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 Music.Theory.Tuning.Alves_1997 - Music.Theory.Tuning.ET - Music.Theory.Tuning.Gann + 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.Load Music.Theory.Tuning.Meyer_1929 - Music.Theory.Tuning.Microtonal_Synthesis + Music.Theory.Tuning.Midi + Music.Theory.Tuning.Partch Music.Theory.Tuning.Polansky_1978 Music.Theory.Tuning.Polansky_1984 Music.Theory.Tuning.Polansky_1985c Music.Theory.Tuning.Polansky_1990 - Music.Theory.Tuning.Riley + Music.Theory.Tuning.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.Meta + Music.Theory.Tuning.Scala.Mode + Music.Theory.Tuning.Sethares_1994 Music.Theory.Tuning.Syntonic - Music.Theory.Tuning.Werckmeister - Music.Theory.Unicode + Music.Theory.Tuning.Type + Music.Theory.Tuning.Wilson + Music.Theory.Wyschnegradsky Music.Theory.Xenakis.S4 Music.Theory.Xenakis.Sieve Music.Theory.Z + Music.Theory.Z.Boros_1990 + Music.Theory.Z.Castren_1994 + Music.Theory.Z.Clough_1979 + Music.Theory.Z.Drape_1999 + Music.Theory.Z.Drape_1999.Cli Music.Theory.Z.Forte_1973 + Music.Theory.Z.Lewin_1980 + Music.Theory.Z.Literature + Music.Theory.Z.Morris_1974 + Music.Theory.Z.Morris_1987 + Music.Theory.Z.Morris_1987.Parse + Music.Theory.Z.Rahn_1980 Music.Theory.Z.Read_1978 - Music.Theory.Z.SRO - Music.Theory.Z12 - Music.Theory.Z12.Castren_1994 - Music.Theory.Z12.Drape_1999 - Music.Theory.Z12.Forte_1973 - Music.Theory.Z12.Lewin_1980 - Music.Theory.Z12.Literature - Music.Theory.Z12.Morris_1974 - Music.Theory.Z12.Morris_1987 - Music.Theory.Z12.Morris_1987.Parse - Music.Theory.Z12.Rahn_1980 - Music.Theory.Z12.Read_1978 - Music.Theory.Z12.SRO - Music.Theory.Z12.TTO + Music.Theory.Z.Tto + Music.Theory.Z.Sro Source-Repository head - Type: darcs - Location: http://rd.slavepianos.org/sw/hmt + Type: git + Location: https://gitlab.com/rd--/hmt