hmt-base (empty) → 0.20

raw patch · 43 files changed

+8111/−0 lines, 43 filesdep +arraydep +basedep +bytestring

Dependencies added: array, base, bytestring, containers, data-ordlist, directory, filepath, lazy-csv, monad-loops, process, random, safe, split, text, time

Files

• Music/Theory/Array.hs +119/−0
• Music/Theory/Array/Cell_Ref.hs +233/−0
• Music/Theory/Array/Csv.hs +235/−0
• Music/Theory/Array/Text.hs +127/−0
• Music/Theory/Bits.hs +39/−0
• Music/Theory/Bool.hs +28/−0
• Music/Theory/Byte.hs +166/−0
• Music/Theory/Combinations.hs +81/−0
• Music/Theory/Concurrent.hs +26/−0
• Music/Theory/Directory.hs +158/−0
• Music/Theory/Directory/Find.hs +73/−0
• Music/Theory/Either.hs +61/−0
• Music/Theory/Enum.hs +54/−0
• Music/Theory/Function.hs +109/−0
• Music/Theory/Graph/Bliss.hs +47/−0
• Music/Theory/Graph/G6.hs +95/−0
• Music/Theory/Graph/Lcf.hs +114/−0
• Music/Theory/Graph/Lgl.hs +99/−0
• Music/Theory/Graph/Planar.hs +141/−0
• Music/Theory/Graph/Type.hs +337/−0
• Music/Theory/Io.hs +62/−0
• Music/Theory/List.hs +1532/−0
• Music/Theory/Map.hs +17/−0
• Music/Theory/Math.hs +290/−0
• Music/Theory/Math/Constant.hs +16/−0
• Music/Theory/Math/Convert.hs +1147/−0
• Music/Theory/Math/Histogram.hs +38/−0
• Music/Theory/Maybe.hs +91/−0
• Music/Theory/Monad.hs +22/−0
• Music/Theory/Opt.hs +156/−0
• Music/Theory/Ord.hs +42/−0
• Music/Theory/Permutations.hs +231/−0
• Music/Theory/Read.hs +197/−0
• Music/Theory/Show.hs +129/−0
• Music/Theory/String.hs +70/−0
• Music/Theory/Time/Duration.hs +183/−0
• Music/Theory/Time/Notation.hs +481/−0
• Music/Theory/Traversable.hs +49/−0
• Music/Theory/Tree.hs +12/−0
• Music/Theory/Tuple.hs +403/−0
• Music/Theory/Unicode.hs +509/−0
• README.md +13/−0
• hmt-base.cabal +79/−0

@@ -0,0 +1,119 @@+-- | Array & table functions+module Music.Theory.Array where++import Data.List {- base -}+import qualified Data.Array as A {- array -}++import qualified Music.Theory.List as T {- hmt-base -}++-- * Association List (List Array)++-- | 'T.minmax' of /k/.+larray_bounds :: Ord k => [(k,v)] -> (k,k)+larray_bounds = T.minmax . map fst++-- | 'A.array' of association list.+larray :: A.Ix k => [(k,v)] -> A.Array k v+larray a = A.array (larray_bounds a) a++-- * List Table++-- | Plain list representation of a two-dimensional table of /a/ in+-- row-order.  Tables are regular, ie. all rows have equal numbers of+-- columns.+type Table a = [[a]]++-- | Table row count.+tbl_rows :: Table t -> Int+tbl_rows = length++-- | Table column count, assumes table is regular.+tbl_columns :: Table t -> Int+tbl_columns tbl =+  case tbl of+    [] -> 0+    r0:_ -> length r0++-- | Determine is table is regular, ie. all rows have the same number of columns.+--+-- > tbl_is_regular [[0..3],[4..7],[8..11]] == True+tbl_is_regular :: Table t -> Bool+tbl_is_regular = (== 1) . length . nub . map length++-- | Map /f/ at table, padding short rows with /k/.+tbl_make_regular :: (t -> u,u) -> Table t -> Table u+tbl_make_regular (f,k) tbl =+    let z = maximum (map length tbl)+    in map (T.pad_right k z . map f) tbl++-- | Append a sequence of /nil/ (or default) values to each row of /tbl/+-- so to make it regular (ie. all rows of equal length).+tbl_make_regular_nil :: t -> Table t -> Table t+tbl_make_regular_nil k = tbl_make_regular (id,k)++-- * Matrix Indices++-- | Matrix dimensions are written (rows,columns).+type Dimensions i = (i,i)++-- | Matrix indices are written (row,column) & are here _zero_ indexed.+type Ix i = (i,i)++-- | Translate 'Ix' by row and column delta.+--+-- > ix_translate (1,2) (3,4) == (4,6)+ix_translate :: Num t => (t,t) -> Ix t -> Ix t+ix_translate (dr,dc) (r,c) = (r + dr,c + dc)++-- | Modulo 'Ix' by 'Dimensions'.+--+-- > ix_modulo (4,4) (3,7) == (3,3)+ix_modulo :: Integral t => Dimensions t -> Ix t -> Ix t+ix_modulo (nr,nc) (r,c) = (r `mod` nr,c `mod` nc)++-- | Given number of columns and row index, list row indices.+--+-- > row_indices 3 1 == [(1,0),(1,1),(1,2)]+row_indices :: (Enum t, Num t) => t -> t -> [Ix t]+row_indices nc r = map (\c -> (r,c)) [0 .. nc - 1]++-- | Given number of rows and column index, list column indices.+--+-- > column_indices_at 3 1 == [(0,1),(1,1),(2,1)]+column_indices_at :: (Enum t, Num t) => t -> t -> [Ix t]+column_indices_at nr c = map (\r -> (r,c)) [0 .. nr - 1]++-- | All zero-indexed matrix indices, in row order.  This is the order+-- given by 'sort'.+--+-- > matrix_indices (2,3) == [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2)]+-- > sort (matrix_indices (2,3)) == matrix_indices (2,3)+matrix_indices :: (Enum t, Num t) => Dimensions t -> [Ix t]+matrix_indices (nr,nc) = concatMap (row_indices nc) [0 .. nr - 1 ]++-- | Corner indices of given 'Dimensions', in row order.+--+-- > matrix_corner_indices (2,3) == [(0,0),(0,2),(1,0),(1,2)]+matrix_corner_indices :: Num t => Dimensions t -> [Ix t]+matrix_corner_indices (nr,nc) = [(0,0),(0,nc - 1),(nr - 1,0),(nr - 1,nc - 1)]++-- | Parallelogram corner indices, given as rectangular 'Dimensions' with an+-- offset for the lower indices.+--+-- > parallelogram_corner_indices ((2,3),2) == [(0,0),(0,2),(1,2),(1,4)]+parallelogram_corner_indices :: Num t => (Dimensions t,t) -> [Ix t]+parallelogram_corner_indices ((nr,nc),o) = [(0,0),(0,nc - 1),(nr - 1,o),(nr - 1,nc + o - 1)]++-- | Apply 'ix_modulo' and 'ix_translate' for all 'matrix_indices',+-- ie. all translations of a 'shape' in row order.  The resulting 'Ix'+-- sets are not sorted and may have duplicates.+--+-- > concat (all_ix_translations (2,3) [(0,0)]) == matrix_indices (2,3)+all_ix_translations :: Integral t => Dimensions t -> [Ix t] -> [[Ix t]]+all_ix_translations dm ix =+    let f z = ix_modulo dm . ix_translate z+    in map (\dx -> map (f dx) ix) (matrix_indices dm)++-- | Sort sets into row order and remove duplicates.+all_ix_translations_uniq :: Integral t => Dimensions t -> [Ix t] -> [[Ix t]]+all_ix_translations_uniq dm = nub . map sort . all_ix_translations dm

@@ -0,0 +1,233 @@+-- | Cell references & indexing.+module Music.Theory.Array.Cell_Ref where++import Data.Char {- base -}+import Data.Function {- base -}+import Data.Maybe {- base -}++import qualified Data.Array as A {- array -}++-- | @A@ indexed case-insensitive column references.  The column following @Z@ is @AA@.+newtype Column_Ref = Column_Ref {column_ref_string :: String}++{-+--import Data.String {- base -}+instance IsString Column_Ref where fromString = Column_Ref+-}++instance Read Column_Ref where readsPrec _ s = [(Column_Ref s,[])]+instance Show Column_Ref where show = column_ref_string+instance Eq Column_Ref where (==) = (==) `on` column_index+instance Ord Column_Ref where compare = compare `on` column_index++instance Enum Column_Ref where+    fromEnum = column_index+    toEnum = column_ref++instance A.Ix Column_Ref where+    range = column_range+    index = interior_column_index+    inRange = column_in_range+    rangeSize = column_range_size++-- | Inclusive range of column references.+type Column_Range = (Column_Ref,Column_Ref)++-- | @1@-indexed row reference.+type Row_Ref = Int++-- | Zero index of 'Row_Ref'.+row_index :: Row_Ref -> Int+row_index r = r - 1++-- | Inclusive range of row references.+type Row_Range = (Row_Ref,Row_Ref)++-- | Cell reference, column then row.+type Cell_Ref = (Column_Ref,Row_Ref)++-- | Inclusive range of cell references.+type Cell_Range = (Cell_Ref,Cell_Ref)++-- | Case folding letter to index function.  Only valid for ASCII letters.+--+-- > map letter_index ['A' .. 'Z'] == [0 .. 25]+-- > map letter_index ['a','d' .. 'm'] == [0,3 .. 12]+letter_index :: Char -> Int+letter_index c = fromEnum (toUpper c) - fromEnum 'A'++-- | Inverse of 'letter_index'.+--+-- > map index_letter [0,3 .. 12] == ['A','D' .. 'M']+index_letter :: Int -> Char+index_letter i = toEnum (i + fromEnum 'A')++-- | Translate column reference to @0@-index.+--+-- > :set -XOverloadedStrings+-- > map column_index ["A","c","z","ac","XYZ"] == [0,2,25,28,17575]+column_index :: Column_Ref -> Int+column_index (Column_Ref c) =+    let m = iterate (* 26) 1+        i = reverse (map letter_index c)+    in sum (zipWith (*) m (zipWith (+) [0..] i))++-- | Column reference to interior index within specified range.+--   Type specialised 'Data.Ix.index'.+--+-- > map (Data.Ix.index ('A','Z')) ['A','C','Z'] == [0,2,25]+-- > map (interior_column_index ("A","Z")) ["A","C","Z"] == [0,2,25]+--+-- > map (Data.Ix.index ('B','C')) ['B','C'] == [0,1]+-- > map (interior_column_index ("B","C")) ["B","C"] == [0,1]+interior_column_index :: Column_Range -> Column_Ref -> Int+interior_column_index (l,r) c =+    let n = column_index c+        l' = column_index l+        r' = column_index r+    in if n > r'+       then error (show ("interior_column_index",l,r,c))+       else n - l'++-- | Inverse of 'column_index'.+--+-- > let c = ["A","Z","AA","AZ","BA","BZ","CA"]+-- > map column_ref [0,25,26,51,52,77,78] == c+--+-- > column_ref (0+25+1+25+1+25+1) == "CA"+column_ref :: Int -> Column_Ref+column_ref =+    let rec n = case n `quotRem` 26 of+                  (0,r) -> [index_letter r]+                  (q,r) -> index_letter (q - 1) : rec r+    in Column_Ref . rec++-- | Type specialised 'pred'.+--+-- > column_ref_pred "DF" == "DE"+column_ref_pred :: Column_Ref -> Column_Ref+column_ref_pred = pred++-- | Type specialised 'succ'.+--+-- > column_ref_succ "DE" == "DF"+column_ref_succ :: Column_Ref -> Column_Ref+column_ref_succ = succ++-- | Bimap of 'column_index'.+--+-- > column_indices ("b","p") == (1,15)+-- > column_indices ("B","IT") == (1,253)+column_indices :: Column_Range -> (Int,Int)+column_indices =+    let bimap f (i,j) = (f i,f j)+    in bimap column_index++-- | Type specialised 'Data.Ix.range'.+--+-- > column_range ("L","R") == ["L","M","N","O","P","Q","R"]+-- > Data.Ix.range ('L','R') == "LMNOPQR"+column_range :: Column_Range -> [Column_Ref]+column_range rng =+    let (l,r) = column_indices rng+    in map column_ref [l .. r]++-- | Type specialised 'Data.Ix.inRange'.+--+-- > map (column_in_range ("L","R")) ["A","N","Z"] == [False,True,False]+-- > map (column_in_range ("L","R")) ["L","N","R"] == [True,True,True]+--+-- > map (Data.Ix.inRange ('L','R')) ['A','N','Z'] == [False,True,False]+-- > map (Data.Ix.inRange ('L','R')) ['L','N','R'] == [True,True,True]+column_in_range :: Column_Range -> Column_Ref -> Bool+column_in_range rng c =+    let (l,r) = column_indices rng+        k = column_index c+    in k >= l && k <= r++-- | Type specialised 'Data.Ix.rangeSize'.+--+-- > map column_range_size [("A","Z"),("AA","ZZ")] == [26,26 * 26]+-- > Data.Ix.rangeSize ('A','Z') == 26+column_range_size :: Column_Range -> Int+column_range_size = (+ 1) . negate . uncurry (-) . column_indices++-- | Type specialised 'Data.Ix.range'.+row_range :: Row_Range -> [Row_Ref]+row_range = A.range++-- | The standard uppermost leftmost cell reference, @A1@.+--+-- > Just cell_ref_minima == parse_cell_ref "A1"+cell_ref_minima :: Cell_Ref+cell_ref_minima = (Column_Ref "A",1)++-- | Cell reference parser for standard notation of (column,row).+--+-- > parse_cell_ref "CC348" == Just ("CC",348)+parse_cell_ref :: String -> Maybe Cell_Ref+parse_cell_ref s =+    case span isUpper s of+      ([],_) -> Nothing+      (c,r) -> case span isDigit r of+                 (n,[]) -> Just (Column_Ref c,read n)+                 _ -> Nothing++-- | 'isJust' of 'parse_cell_ref'.+is_cell_ref :: String -> Bool+is_cell_ref = isJust . parse_cell_ref++-- | 'fromJust' of 'parse_cell_ref'+parse_cell_ref_err :: String -> Cell_Ref+parse_cell_ref_err = fromMaybe (error "parse_cell_ref") . parse_cell_ref++-- | Cell reference pretty printer.+--+-- > cell_ref_pp ("CC",348) == "CC348"+cell_ref_pp :: Cell_Ref -> String+cell_ref_pp (Column_Ref c,r) = c ++ show r++-- | Translate cell reference to @0@-indexed pair.+--+-- > cell_index ("CC",348) == (80,347)+-- > Data.Ix.index ((Column_Ref "AA",1),(Column_Ref "ZZ",999)) (Column_Ref "CC",348) == 54293+cell_index :: Cell_Ref -> (Int,Int)+cell_index (c,r) = (column_index c,row_index r)++-- | Inverse of cell_index.+--+-- > index_to_cell (80,347) == (Column_Ref "CC",348)+-- > index_to_cell (4,5) == (Column_Ref "E",6)+index_to_cell :: (Int,Int) -> Cell_Ref+index_to_cell (c,r) = (column_ref c,r + 1)++-- | 'cell_index' of 'parse_cell_ref_err'+parse_cell_index :: String -> (Int,Int)+parse_cell_index = cell_index . parse_cell_ref_err++-- | Type specialised 'Data.Ix.range', cells are in column-order.+--+-- > cell_range (("AA",1),("AC",1)) == [("AA",1),("AB",1),("AC",1)]+--+-- > let r = [("AA",1),("AA",2),("AB",1),("AB",2),("AC",1),("AC",2)]+-- > 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)]+-- > 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)]+-- > 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)]

@@ -0,0 +1,235 @@+-- | Regular matrix array data, Csv, column & row indexing.+module Music.Theory.Array.Csv where++import Data.List {- base -}++import qualified Data.Array as A {- array -}+import qualified Safe {- safe -}+import qualified Text.CSV.Lazy.String as C {- lazy-csv -}++import qualified Music.Theory.Array as T {- hmt-base -}+import qualified Music.Theory.Array.Cell_Ref as R {- hmt-base -}+import qualified Music.Theory.Io as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Tuple as T {- hmt-base -}++-- * Field / Quote++-- | Quoting is required is the string has a double-quote, comma newline or carriage-return.+csv_requires_quote :: String -> Bool+csv_requires_quote = any (`elem` "\",\n\r")++-- | Quoting places double-quotes at the start and end and escapes double-quotes.+csv_quote :: String -> String+csv_quote fld =+  let esc s =+        case s of+          [] -> []+          '"':s' -> '"' : '"' : esc s'+          c:s' -> c : esc s'+  in '"' : esc fld ++ "\""++-- | Quote field if required.+csv_quote_if_req :: String -> String+csv_quote_if_req fld = if csv_requires_quote fld then csv_quote fld else fld++-- * Table++-- | When reading a CSV file is the first row a header?+type Csv_Has_Header = Bool++-- | Alias for 'Char', allow characters other than @,@ as delimiter.+type Csv_Delimiter = Char++-- | Alias for 'Bool', allow linebreaks in fields.+type Csv_Allow_Linebreaks = Bool++-- | When writing a CSV file should the delimiters be aligned,+-- ie. should columns be padded with spaces, and if so at which side+-- of the data?+data Csv_Align_Columns = Csv_No_Align | Csv_Align_Left | Csv_Align_Right++-- | CSV options.+type Csv_Opt = (Csv_Has_Header,Csv_Delimiter,Csv_Allow_Linebreaks,Csv_Align_Columns)++-- | Default CSV options, no header, comma delimiter, no linebreaks, no alignment.+def_csv_opt :: Csv_Opt+def_csv_opt = (False,',',False,Csv_No_Align)++-- | CSV table, ie. a 'Table' with 'Maybe' a header.+type Csv_Table a = (Maybe [String],T.Table a)++-- | Read 'Csv_Table' from @CSV@ file.+csv_table_read :: Csv_Opt -> (String -> a) -> FilePath -> IO (Csv_Table a)+csv_table_read (hdr,delim,brk,_) f fn = do+  s <- T.read_file_utf8 fn+  let t = C.csvTable (C.parseDSV brk delim s)+      p = C.fromCSVTable t+      (h,d) = if hdr then (Just (head p),tail p) else (Nothing,p)+  return (h,map (map f) d)++-- | Read 'T.Table' only with 'def_csv_opt'.+csv_table_read_def :: (String -> a) -> FilePath -> IO (T.Table a)+csv_table_read_def f = fmap snd . csv_table_read def_csv_opt f++-- | Read plain CSV 'T.Table'.+csv_table_read_plain :: FilePath -> IO (T.Table String)+csv_table_read_plain = csv_table_read_def id++-- | Read and process @CSV@ 'Csv_Table'.+csv_table_with :: Csv_Opt -> (String -> a) -> FilePath -> (Csv_Table a -> b) -> IO b+csv_table_with opt f fn g = fmap g (csv_table_read opt f fn)++-- | Align table according to 'Csv_Align_Columns'.+--+-- > csv_table_align Csv_No_Align [["a","row","and"],["then","another","one"]]+csv_table_align :: Csv_Align_Columns -> T.Table String -> T.Table String+csv_table_align align tbl =+    let c = transpose tbl+        n = map (maximum . map length) c+        ext k s = let pd = replicate (k - length s) ' '+                  in case align of+                       Csv_No_Align -> s+                       Csv_Align_Left -> pd ++ s+                       Csv_Align_Right -> s ++ pd+    in transpose (zipWith (map . ext) n c)++-- | Pretty-print 'Csv_Table'.+csv_table_pp :: (a -> String) -> Csv_Opt -> Csv_Table a -> String+csv_table_pp f (_,delim,brk,align) (hdr,tbl) =+  let tbl' = csv_table_align align (T.mcons hdr (map (map f) tbl))+      (_,t) = C.toCSVTable tbl'+  in C.ppDSVTable brk delim t++-- | 'T.write_file_utf8' of 'csv_table_pp'.+csv_table_write :: (a -> String) -> Csv_Opt -> FilePath -> Csv_Table a -> IO ()+csv_table_write f opt fn csv = T.write_file_utf8 fn (csv_table_pp f opt csv)++-- | Write 'Table' only (no header) with 'def_csv_opt'.+csv_table_write_def :: (a -> String) -> FilePath -> T.Table a -> IO ()+csv_table_write_def f fn tbl = csv_table_write f def_csv_opt fn (Nothing,tbl)++-- | Write plain CSV 'Table'.+csv_table_write_plain :: FilePath -> T.Table String -> IO ()+csv_table_write_plain = csv_table_write_def id++-- | @0@-indexed (row,column) cell lookup.+table_lookup :: T.Table a -> (Int,Int) -> a+table_lookup t (r,c) = let ix = Safe.atNote "table_lookup" in (t `ix` r) `ix` c++-- | Row data.+table_row :: T.Table a -> R.Row_Ref -> [a]+table_row t r = Safe.atNote "table_row" t (R.row_index r)++-- | Column data.+table_column :: T.Table a -> R.Column_Ref -> [a]+table_column t c = Safe.atNote "table_column" (transpose t) (R.column_index c)++-- | Lookup value across columns.+table_column_lookup :: Eq a => T.Table a -> (R.Column_Ref,R.Column_Ref) -> a -> Maybe a+table_column_lookup t (c1,c2) e =+    let a = zip (table_column t c1) (table_column t c2)+    in lookup e a++-- | Table cell lookup.+table_cell :: T.Table a -> R.Cell_Ref -> a+table_cell t (c,r) =+    let (r',c') = (R.row_index r,R.column_index c)+    in table_lookup t (r',c')++-- | @0@-indexed (row,column) cell lookup over column range.+table_lookup_row_segment :: T.Table a -> (Int,(Int,Int)) -> [a]+table_lookup_row_segment t (r,(c0,c1)) =+    let r' = Safe.atNote "table_lookup_row_segment" t r+    in take (c1 - c0 + 1) (drop c0 r')++-- | Range of cells from row.+table_row_segment :: T.Table a -> (R.Row_Ref,R.Column_Range) -> [a]+table_row_segment t (r,c) =+    let (r',c') = (R.row_index r,R.column_indices c)+    in table_lookup_row_segment t (r',c')++-- * Array++-- | Translate 'Table' to 'Array'.  It is assumed that the 'Table' is+-- regular, ie. all rows have an equal number of columns.+--+-- > let a = table_to_array [[0,1,3],[2,4,5]]+-- > in (bounds a,indices a,elems a)+--+-- > > (((A,1),(C,2))+-- > > ,[(A,1),(A,2),(B,1),(B,2),(C,1),(C,2)]+-- > > ,[0,2,1,4,3,5])+table_to_array :: T.Table a -> A.Array R.Cell_Ref a+table_to_array t =+    let nr = length t+        nc = length (Safe.atNote "table_to_array" t 0)+        bnd = (R.cell_ref_minima,(toEnum (nc - 1),nr))+        asc = zip (R.cell_range_row_order bnd) (concat t)+    in A.array bnd asc++-- | 'table_to_array' of 'csv_table_read'.+csv_array_read :: Csv_Opt -> (String -> a) -> FilePath -> IO (A.Array R.Cell_Ref a)+csv_array_read opt f fn = fmap (table_to_array . snd) (csv_table_read opt f fn)++-- * Irregular++csv_field_str :: C.CSVField -> String+csv_field_str f =+    case f of+      C.CSVField _ _ _ _ s _ -> s+      C.CSVFieldError _ _ _ _ _ -> error "csv_field_str"++csv_error_recover :: C.CSVError -> C.CSVRow+csv_error_recover e =+    case e of+      C.IncorrectRow _ _ _ f -> f+      C.BlankLine _ _ _ _ -> []+      _ -> error "csv_error_recover: not recoverable"++csv_row_recover :: Either [C.CSVError] C.CSVRow -> C.CSVRow+csv_row_recover r =+    case r of+      Left [e] -> csv_error_recover e+      Left _ -> error "csv_row_recover: multiple errors"+      Right r' -> r'++-- | Read irregular @CSV@ file, ie. rows may have any number of columns, including no columns.+csv_load_irregular :: (String -> a) -> FilePath -> IO [[a]]+csv_load_irregular f fn = do+  s <- T.read_file_utf8 fn+  return (map (map (f . csv_field_str) . csv_row_recover) (C.parseCSV s))++csv_write_irregular :: (a -> String) -> Csv_Opt -> FilePath -> Csv_Table a -> IO ()+csv_write_irregular f opt fn (hdr,tbl) =+  let tbl' = T.tbl_make_regular_nil "" (map (map f) tbl)+  in T.write_file_utf8 fn (csv_table_pp id opt (hdr,tbl'))++csv_write_irregular_def :: (a -> String) -> FilePath -> T.Table a -> IO ()+csv_write_irregular_def f fn tbl = csv_write_irregular f def_csv_opt fn (Nothing,tbl)++-- * Tuples++type P2_Parser t1 t2 = (String -> t1,String -> t2)++csv_table_read_p2 :: P2_Parser t1 t2 -> Csv_Opt -> FilePath -> IO (Maybe (String,String),[(t1,t2)])+csv_table_read_p2 f opt fn = do+  (hdr,dat) <- csv_table_read opt id fn+  return (fmap T.t2_from_list hdr,map (T.p2_from_list f) dat)++type P5_Parser t1 t2 t3 t4 t5 = (String -> t1,String -> t2,String -> t3,String -> t4,String -> t5)+type P5_Writer t1 t2 t3 t4 t5 = (t1 -> String,t2 -> String,t3 -> String,t4 -> String,t5 -> String)++csv_table_read_p5 :: P5_Parser t1 t2 t3 t4 t5 -> Csv_Opt -> FilePath -> IO (Maybe [String],[(t1,t2,t3,t4,t5)])+csv_table_read_p5 f opt fn = do+  (hdr,dat) <- csv_table_read opt id fn+  return (hdr,map (T.p5_from_list f) dat)++csv_table_write_p5 :: P5_Writer t1 t2 t3 t4 t5 -> Csv_Opt -> FilePath -> (Maybe [String],[(t1,t2,t3,t4,t5)]) -> IO ()+csv_table_write_p5 f opt fn (hdr,dat) = csv_table_write id opt fn (hdr,map (T.p5_to_list f) dat)++csv_table_read_t9 :: (String -> t) -> Csv_Opt -> FilePath -> IO (Maybe [String],[T.T9 t])+csv_table_read_t9 f opt fn = do+  (hdr,dat) <- csv_table_read opt id fn+  return (hdr,map (T.t9_from_list . map f) dat)+

@@ -0,0 +1,127 @@+-- | Regular array data as plain text tables.+module Music.Theory.Array.Text where++import Data.List {- base -}++import qualified Data.List.Split as Split {- split -}++import qualified Music.Theory.Array as T {- hmt-base -}+import qualified Music.Theory.Function as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.String as T {- hmt-base -}++-- | Tabular text.+type Text_Table = [[String]]++-- | Split table at indicated places.+--+-- > let tbl = [["1","2","3","4"],["A","B","E","F"],["C","D","G","H"]]+-- > table_split [2,2] tbl+table_split :: [Int] -> Text_Table -> [Text_Table]+table_split pl dat = transpose (map (Split.splitPlaces pl) dat)++-- | Join tables left to right.+--+-- > table_concat [[["1","2"],["A","B"],["C","D"]],[["3","4"],["E","F"],["G","H"]]]+table_concat :: [Text_Table] -> Text_Table+table_concat sq = map concat (transpose sq)++-- | Add a row number column at the front of the table.+--+-- > table_number_rows 0 tbl+table_number_rows :: Int -> Text_Table -> Text_Table+table_number_rows k = zipWith (\i r -> show i : r) [k ..]++{- | (HEADER,PAD-LEFT,EQ-WIDTH,COL-SEP,TBL-DELIM).++Options are:+ has header+ pad text with space to left instead of right,+ make all columns equal width,+ column separator string,+ print table delimiters+-}+type Text_Table_Opt = (Bool,Bool,Bool,String,Bool)++-- | Options for @plain@ layout.+table_opt_plain :: Text_Table_Opt+table_opt_plain = (False,True,False," ",False)++-- | Options for @simple@ layout.+table_opt_simple :: Text_Table_Opt+table_opt_simple = (True,True,False," ",True)++-- | Options for @pipe@ layout.+table_opt_pipe :: Text_Table_Opt+table_opt_pipe = (True,True,False," | ",False)++-- | Pretty-print table.  Table is in row order.+--+-- > let tbl = [["1","2","3","4"],["a","bc","def"],["ghij","klm","no","p"]]+-- > putStrLn$unlines$"": table_pp (True,True,True," ",True) tbl+-- > putStrLn$unlines$"": table_pp (False,False,True," ",False) tbl+table_pp :: Text_Table_Opt -> Text_Table -> [String]+table_pp (has_hdr,pad_left,eq_width,col_sep,print_eot) dat =+    let c = transpose (T.tbl_make_regular_nil "" dat)+        nc = length c+        n = let k = map (maximum . map length) c+            in if eq_width then replicate nc (maximum k) else k+        ext k s = if pad_left then T.pad_left ' ' k s else T.pad_right ' ' k s+        jn = concat . intersperse col_sep+        m = jn (map (`replicate` '-') n)+        w = map jn (transpose (zipWith (map . ext) n c))+        d = map T.delete_trailing_whitespace w+        pr x = if print_eot then T.bracket (m,m) x else x+    in case d of+         [] -> error "table_pp"+         d0:dr -> if has_hdr then d0 : pr dr else pr d++-- | Variant relying on 'Show' instances.+--+-- > table_pp_show table_opt_simple [[1..4],[5..8],[9..12]]+table_pp_show :: Show t => Text_Table_Opt -> T.Table t -> [String]+table_pp_show opt = table_pp opt . map (map show)++-- | Variant in column order (ie. 'transpose').+--+-- > table_pp_column_order table_opt_simple [["a","bc","def"],["ghij","klm","no"]]+table_pp_column_order :: Text_Table_Opt -> Text_Table -> [String]+table_pp_column_order opt = table_pp opt . transpose++{- | Matrix form, ie. header in both first row and first column, in+each case displaced by one location which is empty.++> let h = (map return "abc",map return "efgh")+> let t = table_matrix h (map (map show) [[1,2,3,4],[2,3,4,1],[3,4,1,2]])++>>> putStrLn $ unlines $ table_pp table_opt_simple t+- - - - -+  e f g h+a 1 2 3 4+b 2 3 4 1+c 3 4 1 2+- - - - -++-}+table_matrix :: ([String],[String]) -> Text_Table -> Text_Table+table_matrix (r,c) t = table_concat [[""] : map return r,c : t]++-- | Variant that takes a 'show' function and a /header decoration/ function.+--+-- > table_matrix_opt show id ([1,2,3],[4,5,6]) [[7,8,9],[10,11,12],[13,14,15]]+table_matrix_opt :: (a -> String) -> (String -> String) -> ([a],[a]) -> T.Table a -> Text_Table+table_matrix_opt show_f hd_f nm t =+    let nm' = T.bimap1 (map (hd_f . show_f)) nm+        t' = map (map show_f) t+    in table_matrix nm' t'++{-+-- | Two-tuple 'show' variant.+table_table_p2 :: (Show a,Show b) => Text_Table_Opt -> Maybe [String] -> ([a],[b]) -> [String]+table_table_p2 opt hdr (p,q) = table_table' opt hdr [map show p,map show q]++-- | Three-tuple 'show' variant.+table_table_p3 :: (Show a,Show b,Show c) => Text_Table_Opt -> Maybe [String] -> ([a],[b],[c]) -> [String]+table_table_p3 opt hdr (p,q,r) = table_table' opt hdr [map show p,map show q,map show r]++-}

@@ -0,0 +1,39 @@+-- | Bits functions.+module Music.Theory.Bits where++import Data.Bits {- base -}++-- | 'True' = 1, 'False' = 0+bit_pp :: Bool -> Char+bit_pp b = if b then '1' else '0'++-- | 'map' 'bit_pp'+bits_pp :: [Bool] -> String+bits_pp = map bit_pp++-- | Generate /n/ place bit sequence for /x/.+gen_bitseq :: FiniteBits b => Int -> b -> [Bool]+gen_bitseq n x =+    if finiteBitSize x < n+    then error "gen_bitseq"+    else map (testBit x) (reverse [0 .. n - 1])++-- | Given bit sequence (most to least significant) generate 'Bits' value.+--+-- > :set -XBinaryLiterals+-- > pack_bitseq [True,False,True,False] == 0b1010+-- > pack_bitseq [True,False,False,True,False,False] == 0b100100+-- > 0b100100 == 36+pack_bitseq :: Bits i => [Bool] -> i+pack_bitseq =+    foldl (\n (k,b) -> if b then setBit n k else n) zeroBits .+    zip [0..] .+    reverse++-- | 'bits_pp' of 'gen_bitseq'.+--+-- > :set -XBinaryLiterals+-- > 0xF0 == 0b11110000+-- > gen_bitseq_pp 8 (0xF0::Int) == "11110000"+gen_bitseq_pp :: FiniteBits b => Int -> b -> String+gen_bitseq_pp n = bits_pp . gen_bitseq n

@@ -0,0 +1,28 @@+-- | Boolean functions.+module Music.Theory.Bool where++import Data.List {- base -}++{- | If-then-else as a function.++> ifThenElse True "true" "false" == "true"+-}+ifThenElse :: Bool -> a -> a -> a+ifThenElse p q r = if p then q else r++{- | Case analysis as a function.+     Find first key that is True else elseValue.++> caseElse "z" [(True,"x"),(False,"y")] == "x"+> caseElse "z" [(False,"x"),(False,"y")] == "z"+-}+caseElse :: t -> [(Bool, t)] -> t+caseElse elseValue = maybe elseValue snd . find fst++{- | Case-of analysis as a function.+     Find first key that compares equal to selectValue else elseValue.++> caseOfElse "z" 'b' [('a',"x"),('b',"y")] == "y"+-}+caseOfElse :: Eq k => v -> k -> [(k, v)] -> v+caseOfElse elseValue selectValue = maybe elseValue snd . find ((== selectValue) . fst)

@@ -0,0 +1,166 @@+-- | Byte functions.+module Music.Theory.Byte where++import Control.Monad.ST {- base -}+import Data.Char {- base -}+import Data.Maybe {- base -}+import Data.Word {- base -}+import Numeric {- base -}++import Data.Array.ST {- array -}+import Data.Array.Unsafe {- array -}++import qualified Data.ByteString as B {- bytestring -}+import qualified Data.List.Split as Split {- split -}++import qualified Music.Theory.Math.Convert as T {- hmt-base -}+import qualified Music.Theory.Read as T {- hmt-base -}++{-+import Data.Int {- base -}+import qualified Data.ByteString.Lazy as L {- bytestring -}++-- * LBS++-- | Section function for 'L.ByteString', ie. from (n,m).+--+-- > lbs_slice 4 5 (L.pack [1..10]) == L.pack [5,6,7,8,9]+lbs_slice :: Int64 -> Int64 -> L.ByteString -> L.ByteString+lbs_slice n m = L.take m . L.drop n++-- | Variant of slice with start and end indices (zero-indexed).+--+-- > lbs_section 4 8 (L.pack [1..]) == L.pack [5,6,7,8,9]+lbs_section :: Int64 -> Int64 -> L.ByteString -> L.ByteString+lbs_section l r = L.take (r - l + 1) . L.drop l+-}++-- * Enumerations & Char++-- | 'toEnum' of 'T.word8_to_int'+word8_to_enum :: Enum e => Word8 -> e+word8_to_enum = toEnum . T.word8_to_int++-- | 'T.int_to_word8_maybe' of 'fromEnum'+enum_to_word8 :: Enum e => e -> Maybe Word8+enum_to_word8 = T.int_to_word8_maybe . fromEnum++-- | Type-specialised 'word8_to_enum'+--+-- > map word8_to_char [60,62] == "<>"+word8_to_char :: Word8 -> Char+word8_to_char = word8_to_enum++-- | 'T.int_to_word8' of 'fromEnum'+char_to_word8 :: Char -> Word8+char_to_word8 = T.int_to_word8 . fromEnum++-- | 'T.int_to_word8' of 'digitToInt'+digit_to_word8 :: Char -> Word8+digit_to_word8 = T.int_to_word8 . digitToInt++-- | 'intToDigit' of 'T.word8_to_int'+word8_to_digit :: Word8 -> Char+word8_to_digit = intToDigit . T.word8_to_int++-- * Indexing++-- | 'at' of 'T.word8_to_int'+word8_at :: [t] -> Word8 -> t+word8_at l = (!!) l . T.word8_to_int++-- * Text++-- | Given /n/ in (0,255) make two character hex string.+--+-- > mapMaybe byte_hex_pp [0x0F,0xF0,0xF0F] == ["0F","F0"]+byte_hex_pp :: (Integral i, Show i) => i -> Maybe String+byte_hex_pp n =+    case showHex n "" of+      [c] -> Just ['0',toUpper c]+      [c,d] -> Just (map toUpper [c,d])+      _ -> Nothing++-- | Erroring variant.+byte_hex_pp_err :: (Integral i, Show i) => i -> String+byte_hex_pp_err = fromMaybe (error "byte_hex_pp") . byte_hex_pp++-- | 'byte_hex_pp_err' either plain (ws = False) or with spaces (ws = True).+--   Plain is the same format written by xxd -p and read by xxd -r -p.+--+-- > byte_seq_hex_pp True [0x0F,0xF0] == "0F F0"+byte_seq_hex_pp :: (Integral i, Show i) => Bool -> [i] -> String+byte_seq_hex_pp ws = (if ws then unwords else concat) . map byte_hex_pp_err++-- | Read two character hexadecimal string.+--+-- > mapMaybe read_hex_byte (Split.chunksOf 2 "0FF0F") == [0x0F,0xF0]+read_hex_byte :: (Eq t, Integral t) => String -> Maybe t+read_hex_byte s =+    case s of+      [_,_] -> T.reads_to_read_precise readHex s+      _ -> Nothing++-- | Erroring variant.+read_hex_byte_err :: (Eq t, Integral t) => String -> t+read_hex_byte_err = fromMaybe (error "read_hex_byte") . read_hex_byte++-- | Sequence of 'read_hex_byte_err'+--+-- > read_hex_byte_seq "000FF0FF" == [0x00,0x0F,0xF0,0xFF]+read_hex_byte_seq :: (Eq t, Integral t) => String -> [t]+read_hex_byte_seq = map read_hex_byte_err . Split.chunksOf 2++-- | Variant that filters white space.+--+-- > read_hex_byte_seq_ws "00 0F F0 FF" == [0x00,0x0F,0xF0,0xFF]+read_hex_byte_seq_ws :: (Eq t, Integral t) => String -> [t]+read_hex_byte_seq_ws = read_hex_byte_seq . filter (not . isSpace)++-- * IO++-- | Load binary 'U8' sequence from file.+load_byte_seq :: Integral i => FilePath -> IO [i]+load_byte_seq = fmap (map fromIntegral . B.unpack) . B.readFile++-- | Store binary 'U8' sequence to file.+store_byte_seq :: Integral i => FilePath -> [i] -> IO ()+store_byte_seq fn = B.writeFile fn . B.pack . map fromIntegral++-- | Load hexadecimal text 'U8' sequences from file.+load_hex_byte_seq :: Integral i => FilePath -> IO [[i]]+load_hex_byte_seq = fmap (map read_hex_byte_seq . lines) . readFile++-- | Store 'U8' sequences as hexadecimal text, one sequence per line.+store_hex_byte_seq :: (Integral i,Show i) => FilePath -> [[i]] -> IO ()+store_hex_byte_seq fn = writeFile fn . unlines . map (byte_seq_hex_pp False)++{-++import qualified Data.ByteString.Base64 as Base64 {- base64-bytestring -}+let fn = "/home/rohan/sw/hsc3-data/data/yamaha/dx7/rom/ROM1A.syx"+b <- load_byte_seq fn :: IO [Word8]+let e = B.unpack (Base64.encode (B.pack b))+let r = B.unpack (Base64.decodeLenient (B.pack e))+(length b,length e,length r,b == r) == (4104,5472,4104,True)+map word8_to_char e++-}++-- * Cast++-- > castFloatToWord32 3.141 == 1078527525+castFloatToWord32 :: Float -> Word32+castFloatToWord32 d = runST ((flip readArray 0 =<< castSTUArray =<< newArray (0, 0::Int) d) :: ST s Word32)++-- > castWord32ToFloat 1078527525 == 3.141+castWord32ToFloat :: Word32 -> Float+castWord32ToFloat d = runST ((flip readArray 0 =<< castSTUArray =<< newArray (0, 0::Int) d) :: ST s Float)++-- > castDoubleToWord64 3.141 == 4614255322014802772+castDoubleToWord64 :: Double -> Word64+castDoubleToWord64 d = runST ((flip readArray 0 =<< castSTUArray =<< newArray (0, 0::Int) d) :: ST s Word64)++-- > castWord64ToDouble 4614255322014802772 == 3.141+castWord64ToDouble :: Word64 -> Double+castWord64ToDouble d = runST ((flip readArray 0 =<< castSTUArray =<< newArray (0, 0::Int) d) :: ST s Double)

@@ -0,0 +1,81 @@+-- | Combination functions.+module Music.Theory.Combinations where++import Data.List {- base -}++import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Permutations as T {- hmt-base -}++-- | Number of /k/ element combinations of a set of /n/ elements.+--+-- > map (uncurry nk_combinations) [(4,2),(5,3),(6,3),(13,3)] == [6,10,20,286]+nk_combinations :: Integral a => a -> a -> a+nk_combinations n k = T.nk_permutations n k `div` T.factorial k++-- | /k/ element subsets of /s/.+--+-- > combinations 3 [1..4] == [[1,2,3],[1,2,4],[1,3,4],[2,3,4]]+-- > length (combinations 3 [1..5]) == nk_combinations 5 3+-- > combinations 3 "xyzw" == ["xyz","xyw","xzw","yzw"]+combinations :: Int -> [a] -> [[a]]+combinations k s =+    case (k,s) of+      (0,_) -> [[]]+      (_,[]) -> []+      (_,e:s') -> map (e :) (combinations (k - 1) s') ++ combinations k s'++-- * Dyck++-- | <http://www.acta.sapientia.ro/acta-info/C1-1/info1-9.pdf> (P.110)+--+-- > dyck_words_lex 3 == [[0,0,0,1,1,1],[0,0,1,0,1,1],[0,0,1,1,0,1],[0,1,0,0,1,1],[0,1,0,1,0,1]]+dyck_words_lex :: (Num t, Ord t) => t -> [[t]]+dyck_words_lex n =+  let gen x i n0 n1 =+        let d0 = gen (x ++ [0]) (i + 1) (n0 + 1) n1+            d1 = gen (x ++ [1]) (i + 1) n0 (n1 + 1)+        in if (n0 < n) && (n1 < n) && (n0 > n1)+        then concat [d0,d1]+        else if ((n0 < n) && (n1 < n) && (n0 == n1)) || ((n0 < n) && (n1 == n))+             then d0+             else if (n0 == n) && (n1 < n)+                  then d1+                  else if (n0 == n1) && (n1 == n)+                       then [x]+                       else error "?"+  in gen [0] (1::Int) 1 0++-- | Translate 01 to [].+--+-- > unwords (map dyck_word_to_str (dyck_words_lex 3)) == "[[[]]] [[][]] [[]][] [][[]] [][][]"+dyck_word_to_str :: Integral n => [n] -> [Char]+dyck_word_to_str = map (\n -> if n == 0 then '[' else if n == 1 then ']' else undefined)++-- | Translate [] to 01+dyck_word_from_str :: Integral n => [Char] -> [n]+dyck_word_from_str = map (\x -> if x == '[' then 0 else if x == ']' then 1 else undefined)++-- | Is /x/ a segment of a lattice word.+is_lattice_segment :: Integral n => [n] -> Bool+is_lattice_segment x =+  let h = T.histogram x+      f (i,j) = case lookup (i + 1) h of+                  Nothing -> True+                  Just k -> j >= k+  in all f h++-- | Is /x/ a lattice word.+--+-- is_lattice_word [1,1,1,2,2,1,2,1] == True+is_lattice_word :: Integral n => [n] -> Bool+is_lattice_word = all is_lattice_segment . inits++-- | 'is_lattice_word' of 'reverse'.+is_yamanouchi_word :: Integral n => [n] -> Bool+is_yamanouchi_word = is_lattice_word . reverse++-- | 'is_lattice_word' of 'dyck_word_from_str'+--+-- > is_dyck_word "[][[][[[][]]]]" == True+is_dyck_word :: String -> Bool+is_dyck_word = is_lattice_word . (dyck_word_from_str :: String -> [Int])

@@ -0,0 +1,26 @@+module Music.Theory.Concurrent where++import Control.Concurrent {- base -}++-- | Pause current thread for the indicated duration (in seconds), see 'pauseThreadLimit'.+threadDelaySeconds :: RealFrac n => n -> IO ()+threadDelaySeconds = threadDelay . floor . (*) 1e6++{- | The number of seconds that 'threadDelaySeconds' can wait for.+Values larger than this require a different thread delay mechanism, see 'threadSleepForSeconds'.+The value is the number of microseconds in @maxBound::Int@.+For 64-bit architectures this is not likely to be an issue, however for 32-bit it can be.++> round ((2 ** 31) / (60 * 60) / 1e6) == 1 -- hours+> round ((2 ** 63) / (60 * 60 * 24 * 365 * 100) / 1e6) == 2925 -- years+-}+threadDelaySecondsLimit :: Fractional n => n+threadDelaySecondsLimit = fromIntegral ((maxBound::Int) - 1) / 1e6++-- | Sleep current thread for the indicated duration (in seconds).+--   Divides long sleeps into parts smaller than 'threadSleepForSeconds'.+threadSleepForSeconds :: RealFrac n => n -> IO ()+threadSleepForSeconds n =+    if n < threadDelaySecondsLimit+    then threadDelaySeconds n+    else threadDelaySeconds (threadDelaySecondsLimit :: Double) >> threadSleepForSeconds (n - threadDelaySecondsLimit)

@@ -0,0 +1,158 @@+-- | Directory functions.+module Music.Theory.Directory where++import Control.Monad {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import qualified System.Environment {- base -}++import qualified Data.List.Split {- split -}+import System.Directory {- directory -}+import System.FilePath {- filepath -}++import qualified Music.Theory.Monad {- hmt-base -}++{- | 'takeDirectory' gives different answers depending on whether there is a trailing separator.++> x = ["x/y","x/y/","x","/"]+> map parent_dir x == ["x","x",".","/"]+> map takeDirectory x == ["x","x/y",".","/"]+-}+parent_dir :: FilePath -> FilePath+parent_dir = takeDirectory . dropTrailingPathSeparator++-- | Colon separated path list.+path_split :: String -> [FilePath]+path_split = Data.List.Split.splitOn ":"++{- | Read environment variable and split path.+     Error if enviroment variable not set.++> path_from_env "PATH"+> path_from_env "NONPATH" -- error+-}+path_from_env :: String -> IO [FilePath]+path_from_env k = do+  p <- System.Environment.lookupEnv k+  maybe (error ("Environment variable not set: " ++ k)) (return . path_split) p++{- | Expand a path to include all subdirectories recursively.++> p = ["/home/rohan/sw/hmt-base/Music", "/home/rohan/sw/hmt/Music"]+> r <- path_recursive p+> length r == 44+-}+path_recursive :: [FilePath] -> IO [FilePath]+path_recursive p = do+  p' <- mapM dir_subdirs_recursively p+  return (p ++ concat p')++{- | Scan a list of directories until a file is located, or not.+Stop once a file is located, do not traverse any sub-directory structure.++> mapM (path_scan ["/sbin","/usr/bin"]) ["fsck","ghc"]+-}+path_scan :: [FilePath] -> FilePath -> IO (Maybe FilePath)+path_scan p fn =+    case p of+      [] -> return Nothing+      dir:p' -> let nm = dir </> fn+                    f x = if x then return (Just nm) else path_scan p' fn+                in doesFileExist nm >>= f++-- | Erroring variant.+path_scan_err :: [FilePath] -> FilePath -> IO FilePath+path_scan_err p x =+    let err = error (concat ["path_scan: ",show p,": ",x])+    in fmap (fromMaybe err) (path_scan p x)++{- | Scan a list of directories and return all located files.+Do not traverse any sub-directory structure.+Since 1.2.1.0 there is also findFiles.++> let path = ["/home/rohan/sw/hmt-base","/home/rohan/sw/hmt"]+> path_search path "README.md"+> findFiles path "README.md"+-}+path_search :: [FilePath] -> FilePath -> IO [FilePath]+path_search p fn = do+  let fq = map (\dir -> dir </> fn) p+      chk q = doesFileExist q >>= \x -> return (if x then Just q else Nothing)+  fmap catMaybes (mapM chk fq)++-- | Get sorted list of files at /dir/ with /ext/, ie. ls dir/*.ext+--+-- > dir_list_ext "/home/rohan/rd/j/" ".hs"+dir_list_ext :: FilePath -> String -> IO [FilePath]+dir_list_ext dir ext = do+  l <- listDirectory dir+  let fn = filter ((==) ext . takeExtension) l+  return (sort fn)++-- | Post-process 'dir_list_ext' to gives file-names with /dir/ prefix.+--+-- > dir_list_ext_path "/home/rohan/rd/j/" ".hs"+dir_list_ext_path :: FilePath -> String -> IO [FilePath]+dir_list_ext_path dir ext = fmap (map (dir </>)) (dir_list_ext dir ext)++-- | Subset of files in /dir/ with an extension in /ext/.+--   Extensions include the leading dot and are case-sensitive.+--   Results are relative to /dir/.+dir_subset_rel :: [String] -> FilePath -> IO [FilePath]+dir_subset_rel ext dir = do+  let f nm = takeExtension nm `elem` ext+  c <- getDirectoryContents dir+  return (sort (filter f c))++-- | Variant of dir_subset_rel where results have dir/ prefix.+--+-- > dir_subset [".hs"] "/home/rohan/sw/hmt/cmd"+dir_subset :: [String] -> FilePath -> IO [FilePath]+dir_subset ext dir = fmap (map (dir </>)) (dir_subset_rel ext dir)++-- | Subdirectories (relative) of /dir/.+dir_subdirs_rel :: FilePath -> IO [FilePath]+dir_subdirs_rel dir =+  let sel fn = doesDirectoryExist (dir </> fn)+  in listDirectory dir >>= filterM sel++-- | Subdirectories of /dir/.+dir_subdirs :: FilePath -> IO [FilePath]+dir_subdirs dir = fmap (map (dir </>)) (dir_subdirs_rel dir)++{- | Recursive form of 'dir_subdirs'.++> dir_subdirs_recursively "/home/rohan/sw/hmt-base/Music"+-}+dir_subdirs_recursively :: FilePath -> IO [FilePath]+dir_subdirs_recursively dir = do+  subdirs <- dir_subdirs dir+  case subdirs of+    [] -> return []+    _ -> do+      subdirs' <- mapM dir_subdirs_recursively subdirs+      return (subdirs ++ concat subdirs')++-- | If path is not absolute, prepend current working directory.+--+-- > to_absolute_cwd "x"+to_absolute_cwd :: FilePath -> IO FilePath+to_absolute_cwd x =+    if isAbsolute x+    then return x+    else fmap (</> x) getCurrentDirectory++-- | If /i/ is an existing file then /j/ else /k/.+if_file_exists :: (FilePath,IO t,IO t) -> IO t+if_file_exists (i,j,k) = Music.Theory.Monad.m_if (doesFileExist i,j,k)++-- | 'createDirectoryIfMissing' (including parents) and then 'writeFile'+writeFile_mkdir :: FilePath -> String -> IO ()+writeFile_mkdir fn s = do+  let dir = takeDirectory fn+  createDirectoryIfMissing True dir+  writeFile fn s++-- | 'writeFile_mkdir' only if file does not exist.+writeFile_mkdir_x :: FilePath -> String -> IO ()+writeFile_mkdir_x fn txt = if_file_exists (fn,return (),writeFile_mkdir fn txt)

@@ -0,0 +1,73 @@+-- | Directory functions using 'find' system utility.+module Music.Theory.Directory.Find where++import Data.List {- base -}+import Data.Maybe {- base -}++import qualified System.Process {- process -}++{- | Find files having indicated filename.+This runs the system utility /find/, so is Unix only.++> dir_find "DX7-ROM1A.syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+-}+dir_find :: FilePath -> FilePath -> IO [FilePath]+dir_find fn dir = fmap lines (System.Process.readProcess "find" [dir,"-name",fn] "")++{- | Require that exactly one file is located, else error.++> dir_find_1 "DX7-ROM1A.syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+-}+dir_find_1 :: FilePath -> FilePath -> IO FilePath+dir_find_1 fn dir = do+  r <- dir_find fn dir+  case r of+    [x] -> return x+    _ -> error "dir_find_1?"++{- | Recursively find files having case-insensitive filename extension.+This runs the system utility /find/, so is Unix only.++> dir_find_ext ".syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+-}+dir_find_ext :: String -> FilePath -> IO [FilePath]+dir_find_ext ext dir = fmap lines (System.Process.readProcess "find" [dir,"-iname",'*' : ext] "")++{- | Post-process 'dir_find_ext' to delete starting directory.++> dir_find_ext_rel ".syx" "/home/rohan/sw/hsc3-data/data/yamaha/"+-}+dir_find_ext_rel :: String -> FilePath -> IO [FilePath]+dir_find_ext_rel ext dir =+  let f = fromMaybe (error "dir_find_ext_rel?") . stripPrefix dir+  in fmap (map f) (dir_find_ext ext dir)++{- | Scan each directory on path recursively for file.+Stop once a file is located.+Runs 'dir_find' so is Unix only.++> path_scan_recursively ["/home/rohan/sw/hmt-base"] "Directory.hs"+-}+path_scan_recursively :: [FilePath] -> FilePath -> IO (Maybe FilePath)+path_scan_recursively p fn =+  case p of+    [] -> return Nothing+    dir:p' -> do+      r <- dir_find fn dir+      case r of+        [] -> path_scan_recursively p' fn+        x:_ -> return (Just x)++{- | Search each directory on path recursively for file.+Runs 'dir_find' so is Unix only.++> path_search_recursively ["/home/rohan/sw"] "README.md"+-}+path_search_recursively :: [FilePath] -> FilePath -> IO [FilePath]+path_search_recursively p fn =+  case p of+    [] -> return []+    dir:p' -> do+      r <- dir_find fn dir+      r' <- path_search_recursively p' fn+      return (r ++ r')

@@ -0,0 +1,61 @@+-- | Either+module Music.Theory.Either where++import Data.Maybe {- base -}++-- | Maybe 'Left' of 'Either'.+from_left :: Either a b -> Maybe a+from_left e =+    case e of+      Left x -> Just x+      _ -> Nothing++-- | 'fromJust' of 'from_left'+from_left_err :: Either t e -> t+from_left_err = fromMaybe (error "from_left_err") . from_left++-- | Maybe 'Right' of 'Either'.+from_right :: Either x t -> Maybe t+from_right e =+    case e of+      Left _ -> Nothing+      Right r -> Just r++-- | 'fromJust' of 'from_right'+from_right_err :: Either e t -> t+from_right_err = fromMaybe (error "from_right_err") . from_right++-- | Flip from right to left, ie. 'either' 'Right' 'Left'+either_swap :: Either a b -> Either b a+either_swap = either Right Left++{- | 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++-- | Lower 'Either' to 'Maybe' by discarding 'Left'.+either_to_maybe :: Either a b -> Maybe b+either_to_maybe = either (const Nothing) Just++-- | Data.Either.isLeft, which however hugs doesn't know of.+is_left :: Either a b -> Bool+is_left e = case e of { Left  _ -> True; Right _ -> False }++-- | Data.Either.isRight, which however hugs doesn't know of.+is_right :: Either a b -> Bool+is_right e = case e of { Left  _ -> False; Right _ -> True }++-- | Data.Either.partitionEithers, which however hugs doesn't know of.+partition_eithers :: [Either a b] -> ([a],[b])+partition_eithers =+  let left  a ~(l, r) = (a:l, r)+      right a ~(l, r) = (l, a:r)+  in foldr (either left right) ([],[])

@@ -0,0 +1,54 @@+-- | Enumeration functions.+module Music.Theory.Enum where++import Data.List {- base -}++-- | Generic variant of 'fromEnum' (p.263).+genericFromEnum :: (Integral i,Enum e) => e -> i+genericFromEnum = fromIntegral . fromEnum++-- | Generic variant of 'toEnum' (p.263).+genericToEnum :: (Integral i,Enum e) => i -> e+genericToEnum = toEnum . fromIntegral++-- | Variant of 'enumFromTo' that, if /p/ is after /q/, cycles from+-- 'maxBound' to 'minBound'.+--+-- > import Data.Word+-- > enum_from_to_cyclic (254 :: Word8) 1 == [254,255,0,1]+enum_from_to_cyclic :: (Bounded a, Enum a) => a -> a -> [a]+enum_from_to_cyclic p q =+    if fromEnum p > fromEnum q+    then [p .. maxBound] ++ [minBound .. q]+    else [p .. q]++-- | Variant of 'enumFromTo' that, if /p/ is after /q/, enumerates+-- from /q/ to /p/.+--+-- > enum_from_to_reverse 5 1 == [5,4,3,2,1]+-- > enum_from_to_reverse 1 5 == enumFromTo 1 5+enum_from_to_reverse :: Enum a => a -> a -> [a]+enum_from_to_reverse p q =+    if fromEnum p > fromEnum q+    then reverse [q .. p]+    else [p .. q]++-- | All elements in sequence.+--+-- > (enum_univ :: [Data.Word.Word8]) == [0 .. 255]+enum_univ :: (Bounded t,Enum t) => [t]+enum_univ = [minBound .. maxBound]++-- | List of 'Enum' values not in sorted input list.+--+-- > enum_list_gaps "abdh" == "cefg"+enum_list_gaps :: (Enum t,Eq t) => [t] -> [t]+enum_list_gaps l =+  let e0 = head l+      eN = last l+      f x = x `notElem` l+  in filter f [e0 .. eN]++-- | 'enum_list_gaps' of 'sort'+enum_set_gaps :: (Enum t,Eq t,Ord t) => [t] -> [t]+enum_set_gaps = enum_list_gaps . sort

@@ -0,0 +1,109 @@+-- | "Data.Function" related functions.+module Music.Theory.Function where++import Data.Bifunctor {- base -}+import Data.Function {- base -}++-- | Unary operator.+type UOp t = t -> t++-- | Binary operator.+type BinOp t = t -> t -> t++-- | Iterate the function /f/ /n/ times, the inital value is /x/.+--+-- > recur_n 5 (* 2) 1 == 32+-- > take (5 + 1) (iterate (* 2) 1) == [1,2,4,8,16,32]+recur_n :: Integral n => n -> (t -> t) -> t -> t+recur_n n f x = if n < 1 then x else recur_n (n - 1) f (f x)++-- | 'const' of 'const'.+--+-- > const2 5 undefined undefined == 5+-- > const (const 5) undefined undefined == 5+const2 :: a -> b -> c -> a+const2 x _ _ = x++-- * Predicate composition.++-- | '&&' of predicates, ie. do predicates /f/ and /g/ both hold at /x/.+predicate_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool+predicate_and f g x = f x && g x++-- | List variant of 'predicate_and', ie. 'foldr1'+--+-- > let r = [False,False,True,False,True,False]+-- > map (predicate_all [(> 0),(< 5),even]) [0..5] == r+predicate_all :: [t -> Bool] -> t -> Bool+predicate_all = foldr1 predicate_and+--predicate_all p x = all id (map ($ x) p)++-- | '||' of predicates.+predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool+predicate_or f g x = f x || g x++-- | 'any' of predicates, ie. logical /or/ of list of predicates.+--+-- > let r = [True,False,True,False,True,True]+-- > map (predicate_any [(== 0),(== 5),even]) [0..5] == r+predicate_any :: [t -> Bool] -> t -> Bool+predicate_any p x = any ($ x) p++-- | '==' 'on'.+eq_on :: Eq t => (u -> t) -> u -> u -> Bool+eq_on f = (==) `on` f++-- * Function composition.++-- | 'fmap' '.' 'fmap', ie. @(t -> c) -> (a -> b -> t) -> a -> b -> c@.+fmap2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+fmap2 = fmap . fmap++-- | fmap of fmap2, ie. @(t -> d) -> (a -> b -> c -> t) -> a -> b -> c -> d@.+fmap3 :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))+fmap3 = fmap . fmap2++-- | fmap of fmap3.+fmap4 :: (Functor f, Functor g, Functor h, Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b)))+fmap4 = fmap . fmap3++-- | fmap of fmap4+fmap5 :: (Functor f, Functor g, Functor h, Functor i, Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b))))+fmap5 = fmap . fmap4++-- | fmap of fmap5+fmap6 :: (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)))))+fmap6 = fmap . fmap5++-- . is infixr 9, this allows f . g .: h+infixr 8 .:, .::, .:::, .::::, .:::::++-- | Operator name for fmap2.+(.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+(.:) = fmap2++-- | Operator name for fmap3.+(.::) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))+(.::) = fmap3++-- | Operator name for fmap4.+(.:::) :: (Functor f, Functor g, Functor h,Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b)))+(.:::) = fmap4++-- | Operator name for fmap5.+(.::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b))))+(.::::) = fmap5++-- | Operator name for fmap6.+(.:::::) :: (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)))))+(.:::::) = fmap6++-- * Bimap++-- | Apply f to both sides of p, , ie. 'Data.Bifunctor.bimap' /f/ /f/.  This is the generic version of bimap1.+bimap1f :: Bifunctor p => (a -> b) -> p a a -> p b b+bimap1f f = bimap f f++-- | Apply /f/ to both elements of a two-tuple.  Type-specialised bimap1f.+bimap1 :: (t -> u) -> (t,t) -> (u,u)+bimap1 = bimap1f

@@ -0,0 +1,47 @@+-- | <http://www.tcs.hut.fi/Software/bliss/fileformat.shtml>+module Music.Theory.Graph.Bliss where++import qualified Music.Theory.Graph.Type as T {- hmt-base -}++-- | Problem is (n-vertices,n-edges)+bliss_parse_problem :: String -> (Int,Int)+bliss_parse_problem txt =+  case words txt of+    ["p","edge",n,e] -> (read n,read e)+    _ -> error "bliss_parse_problem"++-- | Vertex colour is (vertex,colour)+bliss_parse_vertex_colour :: String -> (Int,Int)+bliss_parse_vertex_colour txt =+  case words txt of+    ["n",v,e] -> (read v,read e)+    _ -> error "bliss_parse_vertex_color"++-- | Edge is (vertex,vertex)+bliss_parse_edge :: String -> (Int,Int)+bliss_parse_edge txt =+  case words txt of+    ["e",v1,v2] -> (read v1,read v2)+    _ -> error "bliss_parse_edge"++-- | (problem,vertex-colours,edges)+--   Bliss data is one-indexed.+type Bliss = ((Int,Int), [(Int,Int)], [(Int,Int)])++-- | Parse 'Bliss'+bliss_parse :: String -> Bliss+bliss_parse txt =+  let c0_is x = (== x) . head+      ln = dropWhile (c0_is 'c') (lines txt) -- c = comment+      ([p],r1) = span (c0_is 'p') ln -- p = problem+      (n,r2) = span (c0_is 'n') r1 -- n = vertex colour+      (e,_) = span (c0_is 'e') r2 -- e = edge+  in (bliss_parse_problem p,map bliss_parse_vertex_colour n,map bliss_parse_edge e)++-- | 'bliss_parse' of 'readFile'+bliss_load :: FilePath -> IO Bliss+bliss_load = fmap bliss_parse . readFile++-- | 'Bliss' (one-indexed) to 'T.G' (zero-indexed)+bliss_to_g :: Bliss -> T.G+bliss_to_g ((k,_),_,e) = ([0 .. k - 1],map (\(i,j) -> (i - 1,j - 1)) e)

@@ -0,0 +1,95 @@+{- | graph6 graph encoding++<http://users.cecs.anu.edu.au/~bdm/nauty/>+<https://users.cecs.anu.edu.au/~bdm/data/formats.html>+-}+module Music.Theory.Graph.G6 where++import Data.Bifunctor {- base -}++import qualified Data.List.Split as Split {- split -}+import qualified System.Process as Process {- process -}++import qualified Music.Theory.Graph.Type as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}++-- * G6 (graph6)++-- | Load Graph6 file, discard optional header if present.+g6_load :: FilePath -> IO [String]+g6_load fn = do+  s <- readFile fn+  let s' = if take 6 s == ">>graph6<<" then drop 6 s else s+  return (lines s')++-- | Load G6 file variant where each line is "Description\tG6"+g6_dsc_load :: FilePath -> IO [(String,String)]+g6_dsc_load fn = do+  s <- readFile fn+  let r = map (T.split_on_1_err "\t") (lines s)+  return r++-- | Call nauty-listg to transform a sequence of G6. (debian = nauty)+g6_to_edg :: [String] -> IO [T.Edg]+g6_to_edg g6 = do+  r <- Process.readProcess "nauty-listg" ["-q","-l0","-e"] (unlines g6)+  return (map T.edg_parse (Split.chunksOf 2 (lines r)))++-- | 'T.edg_to_g' of 'g6_to_edg'+g6_to_g :: [String] -> IO [T.G]+g6_to_g = fmap (map T.edg_to_g) . g6_to_edg++-- | 'g6_to_edg' of 'g6_dsc_load'.+g6_dsc_load_edg :: FilePath -> IO [(String,T.Edg)]+g6_dsc_load_edg fn = do+  dat <- g6_dsc_load fn+  let (dsc,g6) = unzip dat+  gr <- g6_to_edg g6+  return (zip dsc gr)++-- | 'T.edg_to_g' of 'g6_dsc_load_edg'+g6_dsc_load_gr :: FilePath -> IO [(String,T.G)]+g6_dsc_load_gr = fmap (map (second T.edg_to_g)) . g6_dsc_load_edg++{- | Generate the text format read by nauty-amtog.++> e = ((4,3),[(0,3),(1,3),(2,3)])+> m = T.edg_to_adj_mtx_undir (0,1) e+> putStrLn (adj_mtx_to_am m)++-}+adj_mtx_to_am :: T.Adj_Mtx Int -> String+adj_mtx_to_am (nv,mtx) =+  unlines ["n=" ++ show nv+          ,"m"+          ,unlines (map (unwords . map show) mtx)]++-- | Call nauty-amtog to transform a sequence of Adj_Mtx to G6.+--+-- > adj_mtx_to_g6 [m,m]+adj_mtx_to_g6 :: [T.Adj_Mtx Int] -> IO [String]+adj_mtx_to_g6 adj = do+  r <- Process.readProcess "nauty-amtog" ["-q"] (unlines (map adj_mtx_to_am adj))+  return (lines r)++-- | 'adj_mtx_to_g6' of 'T.g_to_adj_mtx_undir'+g_to_g6 :: [T.G] -> IO [String]+g_to_g6 = adj_mtx_to_g6 . map (T.g_to_adj_mtx_undir (0,1))++-- | 'writeFile' of 'g_to_g6'+g_store_g6 :: FilePath -> [T.G] -> IO ()+g_store_g6 fn gr = g_to_g6 gr >>= writeFile fn . unlines++-- | Call nauty-labelg to canonise a set of graphs.+g6_labelg :: [String] -> IO [String]+g6_labelg = fmap lines . Process.readProcess "nauty-labelg" ["-q"] . unlines++{- | 'g6_to_g' of 'g6_labelg' of 'g_to_g6'++> g1 = ([0,1,2,3],[(0,3),(3,1),(3,2),(1,2)])+> g2 = ([0,1,2,3],[(1,0),(0,3),(0,2),(2,3)])+> [g3,g4] <- g_labelg [g1,g2]+> (g1 == g2,g3 == g4)+-}+g_labelg :: [T.G] -> IO [T.G]+g_labelg g = g_to_g6 g >>= g6_labelg >>= g6_to_g

@@ -0,0 +1,114 @@+{- | Lcf (Lederberg/Coxeter/Frucht) notation++The notation only applies to Hamiltonian graphs, since it achieves its+symmetry and conciseness by placing a Hamiltonian cycle in a circular+embedding and then connecting specified pairs of nodes with edges. (EW)++-}+module Music.Theory.Graph.Lcf where++import Data.Complex {- base -}+import Data.List {- base -}++import qualified Music.Theory.Graph.Type as T {- hmt-base -}++-- | Lcf notation (/l/,/k/). ([3,-3],4) is the cubical graph.+type Lcf = ([Int],Int)++-- | Real, alias for 'Double'+type R = Double++-- | Sequence, ie. /l/ /k/ times.+lcf_seq :: Lcf -> [Int]+lcf_seq (l,k) = concat (replicate k l)++-- | Length of 'lcf_seq', ie. |l|k+lcf_degree :: Lcf -> Int+lcf_degree (l,k) = length l * k++-- | 'Lcf' to 'T.Edg' (an edge list)+lcf_to_edg :: Lcf -> T.Edg+lcf_to_edg (l,k) =+  let v_n = length l * k+      add i j = (i + j) `mod` v_n+      v = [0 .. v_n - 1]+  in ((v_n,v_n + (v_n `div` 2))+     ,concat [[(i,i `add` 1) | i <- v]+             ,nub (sort (zipWith (curry T.e_sort) v (zipWith add v (lcf_seq (l,k)))))])++-- | Lcf edge-list to graph labeled with circular co-ordinates.+edg_circ_gr :: R -> T.Edg -> T.Lbl (R,R) ()+edg_circ_gr rad ((n,_),e) =+  let polar_to_rectangular (mg,ph) = let c = mkPolar mg ph in (realPart c,imagPart c)+      ph_incr = (2 * pi) / fromIntegral n+      v = zip [0 .. n - 1] (map (curry polar_to_rectangular rad) [0, ph_incr ..])+  in (v,zip e (repeat ()))++{- | Lcf graph set given at <http://mathworld.wolfram.com/LcfNotation.html>++> length lcf_mw_set == 57+> length (nub (map snd lcf_mw_set)) == 57 -- IE. UNIQ+-}+lcf_mw_set :: [(String, Lcf)]+lcf_mw_set =+  [("Tetrahedral graph",([2,-2],2)) -- ([2],4)+  ,("Utility graph",([3],6)) -- ([3,-3],3)+  ,("3-prism graph",([-3,-2,2],2))+  ,("Cubical graph",([3,-3],4))+  ,("Wagner graph",([4],8))+  ,("3-matchstick graph",([-2,-2,2,2],2))+  ,("4-Möbius ladder",([-4],8))+  ,("5-Möbius ladder",([-5],10))+  ,("5-prism graph",([-5,3,-4,4,-3],2))+  ,("Bidiakis cube",([6,4,-4],4))+  ,("Franklin graph",([5,-5],6))+  ,("Frucht graph",([-5,-2,-4,2,5,-2,2,5,-2,-5,4,2],1))+  ,("Truncated tetrahedral graph",([2,6,-2],4))+  ,("Generalized Petersen graph (6,2)",([-5,2,4,-2,-5,4,-4,5,2,-4,-2,5],1))+  ,("6-Möbius ladder",([-6],12))+  ,("6-prism graph",([-3,3],6))+  ,("Heawood graph",([5,-5],7))+  ,("Generalized Petersen graph (7,2)",([-7,-5,4,-6,-5,4,-4,-7,4,-4,5,6,-4,5],1))+  ,("7-Möbius ladder",([-7],14))+  ,("7-prism graph",([-7,5,3,-6,6,-3,-5],2))+  ,("Cubic vertex-transitive graph Ct19",([-7,7],8))+  ,("Möbius-Kantor graph",([5,-5],8))+  ,("8-Möbius ladder",([-8],16))+  ,("8-prism graph",([-3,3],8))+  ,("Pappus graph",([5,7,-7,7,-7,-5],3))+  ,("Cubic vertex-transitive graph Ct20",([-7,7],9)) -- ([5,-5],9)+  ,("Cubic vertex-transitive graph Ct23",([-9,-2,2],6))+  ,("Generalized Petersen graph (9,2)",([-9,-8,-4,-9,4,8],3))+  ,("Generalized Petersen graph (9,3)",([-9,-6,2,5,-2,-9,5,-9,-5,-9,2,-5,-2,6,-9,2,-9,-2],1))+  ,("9-Möbius ladder",([-9],18))+  ,("9-prism graph",([-9,7,5,3,-8,8,-3,-5,-7],2))+  ,("Desargues graph",([5,-5,9,-9],5))+  ,("Dodecahedral graph",([10,7,4,-4,-7,10,-4,7,-7,4],2))+  ,("Cubic vertex-transitive graph Ct25",([-7,7],10))+  ,("Cubic vertex-transitive graph Ct28",([-6,-6,6,6],5))+  ,("Cubic vertex-transitive graph Ct29",([-9,9],10))+  ,("Generalized Petersen graph (10,4)",([-10,-7,5,-5,7,-6,-10,-5,5,6],2))+  ,("Largest cubic nonplanar graph with diameter 3",([-10,-7,-5,4,7,-10,-7,-4,5,7,-10,-7,6,-5,7,-10,-7,5,-6,7],1))+  ,("10-Möbius ladder",([-10],20))+  ,("10-prism graph",([-3,3],10))+  ,("McGee graph",([12,7,-7],8))+  ,("Truncated cubical graph",([2,9,-2,2,-9,-2],4))+  ,("Truncated octahedral graph",([3,-7,7,-3],6))+  ,("Nauru graph",([5,-9,7,-7,9,-5],4))+  ,("F26A graph",([-7,7],13))+  ,("Tutte-Coxeter graph",([-13,-9,7,-7,9,13],5))+  ,("Dyck graph",([5,-5,13,-13],8))+  ,("Gray graph",([-25,7,-7,13,-13,25],9))+  ,("Truncated dodecahedral graph",([30,-2,2,21,-2,2,12,-2,2,-12,-2,2,-21,-2,2,30,-2,2,-12,-2,2,21,-2,2,-21,-2,2,12,-2,2],2))+  ,("Harries graph",([-29,-19,-13,13,21,-27,27,33,-13,13,19,-21,-33,29],5))+  ,("Harries-Wong graph",([9,25,31,-17,17,33,9,-29,-15,-9,9,25,-25,29,17,-9,9,-27,35,-9,9,-17,21,27,-29,-9,-25,13,19,-9,-33,-17,19,-31,27,11,-25,29,-33,13,-13,21,-29,-21,25,9,-11,-19,29,9,-27,-19,-13,-35,-9,9,17,25,-9,9,27,-27,-21,15,-9,29,-29,33,-9,-25],1))+  ,("Balaban 10-cage",([-9,-25,-19,29,13,35,-13,-29,19,25,9,-29,29,17,33,21,9,-13,-31,-9,25,17,9,-31,27,-9,17,-19,-29,27,-17,-9,-29,33,-25,25,-21,17,-17,29,35,-29,17,-17,21,-25,25,-33,29,9,17,-27,29,19,-17,9,-27,31,-9,-17,-25,9,31,13,-9,-21,-33,-17,-29,29],1))+  ,("Foster graph",([17,-9,37,-37,9,-17],15))+  ,("Biggs-Smith graph",([16,24,-38,17,34,48,-19,41,-35,47,-20,34,-36,21,14,48,-16,-36,-43,28,-17,21,29,-43,46,-24,28,-38,-14,-50,-45,21,8,27,-21,20,-37,39,-34,-44,-8,38,-21,25,15,-34,18,-28,-41,36,8,-29,-21,-48,-28,-20,-47,14,-8,-15,-27,38,24,-48,-18,25,38,31,-25,24,-46,-14,28,11,21,35,-39,43,36,-38,14,50,43,36,-11,-36,-24,45,8,19,-25,38,20,-24,-14,-21,-8,44,-31,-38,-28,37],1))+  ,("Balaban 11-cage",([44,26,-47,-15,35,-39,11,-27,38,-37,43,14,28,51,-29,-16,41,-11,-26,15,22,-51,-35,36,52,-14,-33,-26,-46,52,26,16,43,33,-15,17,-53,23,-42,-35,-28,30,-22,45,-44,16,-38,-16,50,-55,20,28,-17,-43,47,34,-26,-41,11,-36,-23,-16,41,17,-51,26,-33,47,17,-11,-20,-30,21,29,36,-43,-52,10,39,-28,-17,-52,51,26,37,-17,10,-10,-45,-34,17,-26,27,-21,46,53,-10,29,-50,35,15,-47,-29,-41,26,33,55,-17,42,-26,-36,16],1))+  ,("Ljubljana graph",([47,-23,-31,39,25,-21,-31,-41,25,15,29,-41,-19,15,-49,33,39,-35,-21,17,-33,49,41,31,-15,-29,41,31,-15,-25,21,31,-51,-25,23,9,-17,51,35,-29,21,-51,-39,33,-9,-51,51,-47,-33,19,51,-21,29,21,-31,-39],2))+  ,("Tutte 12-cage",([17,27,-13,-59,-35,35,-11,13,-53,53,-27,21,57,11,-21,-57,59,-17],7))]++-- Local Variables:+-- truncate-lines:t+-- End:

@@ -0,0 +1,99 @@+{- | LGL = Large Graph Layout (NCOL, LGL)++<http://lgl.sourceforge.net/#FileFormat>+-}+module Music.Theory.Graph.Lgl where++import Data.Bifunctor {- base -}+import Data.List {- base -}++import qualified Music.Theory.Graph.Type as T {- hmt-base -}+import qualified Music.Theory.Show as T {- hmt-base -}+import qualified Music.Theory.Tuple as T {- hmt-base -}++-- * Ncol++-- | (edge,weight)+type Ncol_Ent t = ((t,t),Maybe Double)++-- | [ncol-entry]+type Ncol t = [Ncol_Ent t]++-- | Parse 'Ncol_Ent' from 'String'+ncol_parse :: Read t => String -> Ncol_Ent t+ncol_parse s =+  case words s of+    [i,j] -> ((read i,read j),Nothing)+    [i,j,k] -> ((read i,read j),read k)+    _ -> error "ncol_parse"++-- | Load 'Ncol' from .ncol file.+ncol_load :: Read t => FilePath -> IO (Ncol t)+ncol_load = fmap (map ncol_parse . lines) . readFile++-- | Type-specialised.+ncol_load_int :: FilePath -> IO (Ncol Int)+ncol_load_int = ncol_load++{- | Format Ncol_Ent.++> ncol_ent_format 4 ((0,1),Nothing) == "0 1"+> ncol_ent_format 4 ((0,1),Just 2.0) == "0 1 2.0000"+-}+ncol_ent_format :: Show t => Int -> Ncol_Ent t -> String+ncol_ent_format k ((i,j),w) = unwords (map show [i,j]) ++ maybe "" ((' ':) . T.double_pp k) w++-- | Store 'Ncol' of 'Int' to .ncol file+ncol_store :: Show t => Int -> FilePath -> Ncol t -> IO ()+ncol_store k fn dat = writeFile fn (unlines (map (ncol_ent_format k) dat))++-- | Type-specialised.+ncol_store_int :: Int -> FilePath -> Ncol Int -> IO ()+ncol_store_int = ncol_store++-- | Ncol data must be un-directed and have no self-arcs.+--   This function sorts edges (i,j) so that i <= j and deletes edges where i == j.+ncol_rewrite_eset :: Ord t => [(t,t)] -> [(t,t)]+ncol_rewrite_eset e = filter (uncurry (/=)) (nub (sort (map T.t2_sort e)))++-- | eset (edge-set) to Ncol (runs 'ncol_rewrite_eset')+eset_to_ncol :: Ord t => [(t,t)] -> Ncol t+eset_to_ncol = map (\e -> (e,Nothing)) . ncol_rewrite_eset++-- | Inverse of 'eset_to_ncol', 'error' if 'Ncol' is weighted+ncol_to_eset :: Ncol t -> [(t,t)]+ncol_to_eset = map (\(e,w) -> case w of {Nothing -> e;_ -> error "ncol_to_eset?"})++-- | 'ncol_store' of 'eset_to_ncol'+ncol_store_eset :: (Ord t,Show t) => FilePath -> [(t,t)] -> IO ()+ncol_store_eset fn = ncol_store undefined fn . eset_to_ncol++-- * Lgl++-- | Lgl is an adjaceny set with optional weights.+type Lgl t = [(t,[(t,Maybe Double)])]++-- | Format 'Lgl', k is floating point precision for optional weights.+lgl_format :: Show t => Int -> Lgl t -> String+lgl_format k =+  let f (i,j) = show i ++ maybe "" ((' ' :) . T.double_pp k) j+      g (i,j) = unlines (('#' : ' ' : show i) : map f j)+  in concatMap g++-- | 'writeFile' of 'lgl_format'+lgl_store :: Show t => Int -> FilePath -> Lgl t -> IO ()+lgl_store k fn = writeFile fn . lgl_format k++-- | adj (adjaceny-set) to 'Lgl'.+adj_to_lgl :: T.Adj t -> Lgl t+adj_to_lgl = map (\(i,j) -> (i,zip j (repeat Nothing)))++-- | Inverse of 'adj_to_lgl', 'error' if 'Lgl' is weighted+lgl_to_adj :: Lgl t -> T.Adj t+lgl_to_adj = map (second (map (\(k,w) -> case w of {Nothing -> k;_ -> error "lgl_to_adj?"})))++-- | 'lgl_store' of 'adj_to_lgl'+lgl_store_adj :: Show t => FilePath -> T.Adj t -> IO ()+lgl_store_adj fn = lgl_store undefined fn . adj_to_lgl++-- > putStrLn $ lgl_format 4 $ adj_to_lgl [(0,[1,2,3]),(1,[2,3]),(2,[3])]

@@ -0,0 +1,141 @@+-- | <https://users.cecs.anu.edu.au/~bdm/plantri/plantri-guide.txt>+module Music.Theory.Graph.Planar where++import System.FilePath {- filepath -}+import System.Process {- process -}+import Text.Printf {- base -}++import qualified Data.ByteString as B {- bytestring -}+import qualified Data.List.Split as S {- split -}++import qualified Music.Theory.Graph.G6 as G6 {- hmt-base -}+import qualified Music.Theory.Graph.Type as T {- hmt-base -}++-- | The 15-character header text indicating a Planar-Code file.+plc_header_txt :: String+plc_header_txt = ">>planar_code<<"++-- | Read Plc header+plc_header :: B.ByteString -> String+plc_header = map (toEnum . fromIntegral) . B.unpack . B.take 15++-- | Read Plc data as list of 'Int'+plc_data :: B.ByteString -> [Int]+plc_data = map fromIntegral . B.unpack . B.drop 15++-- | Calculate length of Plc data given (n-vertices,n-edges).+plc_length :: (Int,Int) -> Int+plc_length (v,e) = v + 1 + 2 * e++-- | Scan Plc data and segment after /k/ zeros.+plc_scanner :: Int -> [Int] -> ([Int],[Int])+plc_scanner =+  let f r k i = case i of+                  0:j -> if k == 1 then (reverse (0 : r),j) else f (0 : r) (k - 1) j+                  e:j -> f (e : r) k j+                  _ -> error "plc_scanner?"+  in f []++-- | (n-vertices,clockwise-edge-sequences)+type Plc = (Int,[[Int]])++plc_n_vertices :: Plc -> Int+plc_n_vertices (k,_) = k++-- | Group Plc data into Plc structure.+plc_group :: Int -> [Int] -> Plc+plc_group k i =+  let c = S.endBy [0] i+  in if length c == k then (k,c) else error "plc_group?"++-- | Segment input data into sequence of Plc.+plc_segment :: [Int] -> [Plc]+plc_segment i =+  case i of+    [] -> []+    k:j -> case plc_scanner k j of+             (r,[]) -> [plc_group k r]+             (r,l) -> plc_group k r : plc_segment l++plc_parse :: B.ByteString -> [Plc]+plc_parse b =+  if plc_header b == plc_header_txt+  then plc_segment (plc_data b)+  else error "plc_load?"++-- | Load sequence of Plc from binary Planar-Code file.+plc_load :: FilePath -> IO [Plc]+plc_load = fmap plc_parse . B.readFile++-- | All edges (one-indexed) at Plc+plc_edge_set :: Plc -> [(Int,Int)]+plc_edge_set (k,n) =+  let v = [1 .. k]+      f (i,j) = map (\x -> (i,x)) j+  in concatMap f (zip v n)++-- | Element in /x/ after /i/, the element after the last is the first.+--+-- > map (plc_next_elem "abcd") "abcd" == "bcda"+plc_next_elem :: Eq t => [t] -> t -> t+plc_next_elem x i =+  case dropWhile (/= i) x of+    [] -> error "plc_next_elem?"+    [_] -> head x+    _:j:_ -> j++-- | The next edge in Plc following /e/.+plc_next_edge :: Plc -> (Int,Int) -> (Int,Int)+plc_next_edge (_,e) (i,j) = let k = plc_next_elem (e !! (j - 1)) i in (j,k)++-- | The face of Plc starting at /e/ (one-indexed edges).+plc_face_from :: Plc -> (Int,Int) -> [(Int,Int)]+plc_face_from p e = e : takeWhile (/= e) (tail (iterate (plc_next_edge p) e))++-- | The set of all faces at Plc (one-indexed edges).+plc_face_set :: Plc -> [[(Int,Int)]]+plc_face_set p =+  let f r e =+        case e of+          [] -> reverse r+          e0:eN -> if any (e0 `elem`) r+                   then f r eN+                   else f (plc_face_from p e0 : r) eN+  in f [] (plc_edge_set p)++-- | Translate 'Plc' into un-directed 'T.G'.  Plc is one-indexed, G is zero-indexed.+plc_to_g :: Plc -> T.G+plc_to_g p =+  let (k,_) = p+      v = [0 .. k - 1]+      f (i,j) = (i - 1,j - 1)+      g (i,j) = i <= j+  in (v,filter g (map f (plc_edge_set p)))++plc_stat :: FilePath -> IO (Int, [(Int, Int, Int)])+plc_stat plc_fn = do+  p_seq <- plc_load plc_fn+  let f p = (plc_n_vertices p,length (plc_edge_set p) `div` 2,length (plc_face_set p))+  return (length p_seq,map f p_seq)++plc_stat_txt :: FilePath -> (Int, [(Int, Int, Int)]) -> [String]+plc_stat_txt fn (k,g) =+  let hdr = printf "%s G=%d" (takeBaseName fn) k+      gr ix (v,e,f) = printf " %d: V=%d E=%d F=%d" ix v e f+  in hdr : zipWith gr [1::Int ..] g++-- | Run "nauty-planarg" to convert (if possible) a set of G6 graphs to Planar-Code.+g6_planarg :: [String] -> IO B.ByteString+g6_planarg =+  -- else see process-extras:readProcessWithExitCode+  let str_to_b :: String -> B.ByteString+      str_to_b = B.pack . map (fromIntegral . fromEnum)+  in fmap str_to_b . readProcess "nauty-planarg" ["-q"] . unlines++-- | 'plc_parse' of 'g6_planarg' of 'G6.g_to_g6'+g_to_plc :: [T.G] -> IO [Plc]+g_to_plc g = fmap plc_parse (G6.g_to_g6 g >>= g6_planarg)++-- | Run "nauty-planarg" to translate named G6 file to named PL file.+g6_to_pl_wr :: FilePath -> FilePath -> IO ()+g6_to_pl_wr g6_fn pl_fn = callProcess "nauty-planarg" ["-q","-p",g6_fn,pl_fn]

@@ -0,0 +1,337 @@+-- | Graph types.+module Music.Theory.Graph.Type where++import Data.Bifunctor {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Data.Graph as Graph {- containers -}++import qualified Music.Theory.List as T {- hmt-base -}++-- * Vertices++v_is_normal :: [Int] -> Maybe Int+v_is_normal v = let k = length v in if v == [0 .. k - 1] then Just k else Nothing++v_is_normal_err :: [Int] -> Int+v_is_normal_err = fromMaybe (error "v_is_normal?") . v_is_normal++-- * Edge++-- | Un-directed edge equality.+--+-- > e_eq_undir (0,1) (1,0) == True+e_eq_undir :: Eq t => (t,t) -> (t,t) -> Bool+e_eq_undir e0 e1 =+  let swap (i,j) = (j,i)+  in e0 == e1 || e0 == swap e1++-- | Sort edge.+--+-- > map e_sort [(0,1),(1,0)] == [(0,1),(0,1)]+e_sort :: Ord t => (t, t) -> (t, t)+e_sort (i,j) = (min i j,max i j)++-- * (vertices,edges) graph++-- | (vertices,edges)+type Gr t = ([t],[(t,t)])++-- | 'Gr' is a functor.+gr_map :: (t -> u) -> Gr t -> Gr u+gr_map f (v,e) = (map f v,map (bimap f f) e)++-- | (|V|,|E|)+gr_degree :: Gr t -> (Int,Int)+gr_degree (v,e) = (length v,length e)++-- | Re-label graph given table.+gr_relabel :: Eq t => [(t,u)] -> Gr t -> Gr u+gr_relabel tbl (v,e) =+  let get z = T.lookup_err z tbl+  in (map get v,map (bimap get get) e)++-- | If (i,j) and (j,i) are both in E delete (j,i) where i < j.+gr_mk_undir :: Ord t => Gr t -> Gr t+gr_mk_undir (v,e) = (v,nub (sort (map e_sort e)))++-- | List of E to G, derives V from E.+eset_to_gr :: Ord t => [(t,t)] -> Gr t+eset_to_gr e =+  let v = sort (nub (concatMap (\(i,j) -> [i,j]) e))+  in (v,e)++-- | Sort v and e.+gr_sort :: Ord t => Gr t -> Gr t+gr_sort (v,e) = (sort v,sort e)++-- | Complete k-graph (un-directed) given list of vertices+--+-- > gr_complete_graph "xyz" == ("xyz",[('x','y'),('x','z'),('y','z')])+gr_complete_graph :: Ord t => [t] -> Gr t+gr_complete_graph v = let e = [(i,j) | i <- v,j <- v,i < j] in (v,e)++-- * Int graph++-- | 'Gr' of 'Int'+type G = Gr Int++-- | Simple text representation of 'G'.  Requires (and checks) that vertices are (0 .. |v|-1).+--   The first line is the number of vertices, following lines are edges.+g_to_text :: G -> String+g_to_text (v,e) =+  let k = v_is_normal_err v+      f (i,j) = unwords (map show [i,j])+  in unlines (show k : map f e)++-- | 'Graph.Graph' to 'G'.+graph_to_g :: Graph.Graph -> G+graph_to_g gr = (Graph.vertices gr,Graph.edges gr)++-- | 'G' to 'Graph.Graph'+--+-- > g = ([0,1,2],[(0,1),(0,2),(1,2)])+-- > g == gr_sort (graph_to_g (g_to_graph g))+g_to_graph :: G -> Graph.Graph+g_to_graph (v,e) = Graph.buildG (minimum v,maximum v) e++-- | Unlabel graph, make table.+--+-- > gr_unlabel ("xyz",[('x','y'),('x','z')]) == (([0,1,2],[(0,1),(0,2)]),[(0,'x'),(1,'y'),(2,'z')])+gr_unlabel :: Eq t => Gr t -> (G,[(Int,t)])+gr_unlabel (v1,e1) =+  let n = length v1+      v2 = [0 .. n - 1]+      tbl = zip v2 v1+      get k = T.reverse_lookup_err k tbl+      e2 = map (bimap get get) e1+  in ((v2,e2),tbl)++-- | 'fst' of 'gr_unlabel'+gr_to_g :: Eq t => Gr t -> G+gr_to_g = fst . gr_unlabel++-- | 'g_to_graph' of 'gr_unlabel'.+--+-- > gr = ("abc",[('a','b'),('a','c'),('b','c')])+-- > (g,tbl) = gr_to_graph gr+gr_to_graph :: Eq t => Gr t -> (Graph.Graph,[(Int,t)])+gr_to_graph gr =+  let ((v,e),tbl) = gr_unlabel gr+  in (Graph.buildG (0,length v - 1) e,tbl)++-- | Complete k-graph (un-directed).+--+-- > g_complete_graph 3 == ([0,1,2],[(0,1),(0,2),(1,2)])+g_complete_graph :: Int -> G+g_complete_graph k = gr_complete_graph [0 .. k - 1]++-- * Edg = edge list (zero-indexed)++-- | ((|V|,|E|),[E])+type Edg = ((Int,Int), [(Int,Int)])++-- | Requires (and checks) that vertices are (0 .. |v| - 1).+g_to_edg :: G -> Edg+g_to_edg (v,e) = ((v_is_normal_err v,length e),e)++-- | Requires (but does not check) that vertices of 'Edg' are all in (0,|v| - 1).+edg_to_g :: Edg -> G+edg_to_g ((nv,ne),e) =+  let v = [0 .. nv - 1]+  in if ne /= length e+     then error (show ("edg_to_g",nv,ne,length e))+     else (v,e)++-- | Parse Edg as printed by nauty-listg.+edg_parse :: [String] -> Edg+edg_parse ln =+  let parse_int_list = map read . words+      parse_int_pairs = T.adj2 2 . parse_int_list+      parse_int_pair = T.unlist1_err . parse_int_pairs+  in case ln of+       [m,e] -> (parse_int_pair m,parse_int_pairs e)+       _ -> error "edg_parse"++-- * Adjacencies++-- | Adjacency list [(left-hand-side,[right-hand-side])]+type Adj t = [(t,[t])]++-- | 'Adj' to edge set.+adj_to_eset :: Ord t => Adj t -> [(t,t)]+adj_to_eset = concatMap (\(i,j) -> zip (repeat i) j)++-- | 'Adj' to 'Gr'+adj_to_gr :: Ord t => Adj t -> Gr t+adj_to_gr = eset_to_gr . adj_to_eset++-- | 'Gr' to 'Adj' (selection-function)+gr_to_adj :: Ord t => (t -> (t,t) -> Maybe t) -> Gr t -> Adj t+gr_to_adj sel_f (v,e) =+  let f k = (k,sort (mapMaybe (sel_f k) e))+  in filter (\(_,a) -> a /= []) (map f v)++-- | 'Gr' to 'Adj' (directed)+--+-- > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])+-- > r = [(0,[1,3]),(2,[1]),(3,[0])]+-- > gr_to_adj_dir g == r+gr_to_adj_dir :: Ord t => Gr t -> Adj t+gr_to_adj_dir =+  let sel_f k (i,j) = if i == k then Just j else Nothing+  in gr_to_adj sel_f++-- | 'Gr' to 'Adj' (un-directed)+--+-- > g = ([0,1,2,3],[(0,1),(2,1),(0,3),(3,0)])+-- > gr_to_adj_undir g == [(0,[1,3,3]),(1,[2])]+gr_to_adj_undir :: Ord t => Gr t -> Adj t+gr_to_adj_undir =+  let sel_f k (i,j) =+        if i == k && j >= k+        then Just j+        else if j == k && i >= k+             then Just i+             else Nothing+  in gr_to_adj sel_f++-- | Adjacency matrix, (|v|,mtx)+type Adj_Mtx t = (Int,[[t]])++{- | Edg to Adj_Mtx for un-directed graph.++> e = ((4,3),[(0,3),(1,3),(2,3)])+> edg_to_adj_mtx_undir (0,1) e == (4,[[0,0,0,1],[0,0,0,1],[0,0,0,1],[1,1,1,0]])++> e = ((4,4),[(0,1),(0,3),(1,2),(2,3)])+> edg_to_adj_mtx_undir (0,1) e == (4,[[0,1,0,1],[1,0,1,0],[0,1,0,1],[1,0,1,0]])++-}+edg_to_adj_mtx_undir :: (t,t) -> Edg -> Adj_Mtx t+edg_to_adj_mtx_undir (false,true) ((nv,_ne),e) =+  let v = [0 .. nv - 1]+      f i j = case find (e_eq_undir (i,j)) e of+                Nothing -> false+                _ -> true+  in (nv,map (\i -> map (f i) v) v)++-- | 'edg_to_adj_mtx_undir' of 'g_to_edg'+g_to_adj_mtx_undir :: (t,t) -> G -> Adj_Mtx t+g_to_adj_mtx_undir o = edg_to_adj_mtx_undir o . g_to_edg++-- | Lookup 'Adj_Mtx' to find connected vertices.+adj_mtx_con :: Eq t => (t,t) -> Adj_Mtx t -> Int -> [Int]+adj_mtx_con (false,true) (_,mx) e =+  let f i j = if i == true then Just j else if i == false then Nothing else error "adj_mtx_con?"+  in catMaybes (zipWith f (mx !! e) [0..])++-- * Labels++-- | Labelled graph, distinct vertex and edge labels.+type Lbl_Gr v v_lbl e_lbl = ([(v,v_lbl)],[((v,v),e_lbl)])++-- | 'Lbl_Gr' of 'Int'+type Lbl v e = Lbl_Gr Int v e++-- | 'Lbl' with () edge labels.+type Lbl_ v = Lbl v ()++-- | Number of vertices and edges.+lbl_degree :: Lbl v e -> (Int,Int)+lbl_degree (v,e) = (length v,length e)++-- | Apply /v/ at vertex labels and /e/ at edge labels.+lbl_bimap :: (v -> v') -> (e -> e') -> Lbl v e -> Lbl v' e'+lbl_bimap v_f e_f (v,e) = (map (fmap v_f) v,map (fmap e_f) e)++-- | Merge two 'Lbl' graphs, do not share vertices, vertex indices at /g1/ are stable.+lbl_merge :: Lbl v e -> Lbl v e -> Lbl v e+lbl_merge (v1,e1) (v2,e2) =+  let m = maximum (map fst v1) + 1+      v3 = map (\(i,j) -> (i + m,j)) v2+      e3 = map (\((i,j),k) -> ((i + m,j + m),k)) e2+  in (v1 ++ v3,e1 ++ e3)++-- | 'foldl1' of 'lbl_merge'+lbl_merge_seq :: [Lbl v e] -> Lbl v e+lbl_merge_seq = foldl1 lbl_merge++-- | Re-write graph so vertex indices are (0 .. n-1) and vertex labels are unique.+lbl_canonical :: (Eq v,Ord v) => Lbl v e -> Lbl v e+lbl_canonical (v1,e1) =+  let v2 = zip [0..] (nub (map snd v1))+      reix i = T.reverse_lookup_err (T.lookup_err i v1) v2+      e2 = map (\((i,j),k) -> ((reix i,reix j),k)) e1+  in (v2,e2)++-- | Re-write edges so that vertex indices are ascending.+lbl_undir :: Lbl v e -> Lbl v e+lbl_undir (v,e) = (v,map (\((i,j),k) -> ((min i j,max i j),k)) e)++-- | 'Lbl' path graph.+lbl_path_graph :: [x] -> Lbl_ x+lbl_path_graph v =+  let n = length v - 1+  in (zip [0 .. n] v+     ,zip (zip [0 .. n - 1] [1 .. n]) (repeat ()))++-- | 'Lbl' complete graph (undirected, no self-edges)+lbl_complete_graph :: [x] -> Lbl_ x+lbl_complete_graph v =+  let n = length v - 1+      u = [0 .. n]+  in (zip u v+     ,zip [(i,j) | i <- u, j <- u, i < j] (repeat ()))++-- | Lookup vertex label with default value.+v_label :: v -> Lbl v e -> Int -> v+v_label def (tbl,_) v = fromMaybe def (lookup v tbl)++-- | 'v_label' with 'error' as default.+v_label_err :: Lbl v e -> Int -> v+v_label_err = v_label (error "v_label")++-- | Lookup edge label with default value.+e_label :: e -> Lbl v e -> (Int,Int) -> e+e_label def (_,tbl) e = fromMaybe def (lookup e tbl)++-- | 'e_label' with 'error' as default.+e_label_err :: Lbl v e -> (Int,Int) -> e+e_label_err = e_label (error "e_label")++-- | Convert from 'Lbl_Gr' to 'Lbl'+lbl_gr_to_lbl :: Eq v => Lbl_Gr v v_lbl e_lbl -> Lbl v_lbl e_lbl+lbl_gr_to_lbl (v,e) =+  let n = length v+      v' = [0 .. n - 1]+      tbl = zip v' (map fst v)+      get k = T.reverse_lookup_err k tbl+      e' = map (\((p,q),r) -> ((get p,get q),r)) e+  in (zip v' (map snd v),e')++-- | Convert from 'Gr' to 'Lbl'.+--+-- > gr_to_lbl ("ab",[('a','b')]) == ([(0,'a'),(1,'b')],[((0,1),('a','b'))])+gr_to_lbl :: Eq t => Gr t -> Lbl t (t,t)+gr_to_lbl (v,e) = lbl_gr_to_lbl (zip v v,zip e e)++-- | Delete edge labels from 'Lbl', replacing with '()'+lbl_delete_edge_labels :: Lbl v e -> Lbl_ v+lbl_delete_edge_labels (v,e) = (v,map (\(x,_) -> (x,())) e)++-- | 'lbl_delete_edge_labels' of 'gr_to_lbl'+gr_to_lbl_ :: Eq t => Gr t -> Lbl_ t+gr_to_lbl_ = lbl_delete_edge_labels . gr_to_lbl++-- | Construct Lbl from set of E, derives V from E.+eset_to_lbl :: Ord t => [(t,t)] -> Lbl_ t+eset_to_lbl e =+  let v = nub (sort (concatMap (\(i,j) -> [i,j]) e))+      get_ix z = fromMaybe (error "eset_to_lbl") (elemIndex z v)+  in (zip [0..] v, map (\(i,j) -> ((get_ix i,get_ix j),())) e)++-- | Unlabel 'Lbl' graph.+lbl_to_g :: Lbl v e -> G+lbl_to_g (v,e) = (map fst v,map fst e)

@@ -0,0 +1,62 @@+-- | "System.IO" related functions.+module Music.Theory.Io where++import Control.Monad {- base -}+import System.IO {- base -}++import qualified Data.ByteString as B {- bytestring -}+import qualified System.Directory as D {- directory -}++import qualified Control.Monad.Loops as Loop {- monad-loops -}++import qualified Data.Text as T {- text -}+import qualified Data.Text.Encoding as T {- text -}+import qualified Data.Text.IO as T {- text -}++-- | 'T.decodeUtf8' of 'B.readFile', implemented via "Data.Text".+read_file_utf8_text :: FilePath -> IO T.Text+read_file_utf8_text = fmap T.decodeUtf8 . B.readFile++-- | Read (strictly) a UTF-8 encoded text file, implemented via "Data.Text".+read_file_utf8 :: FilePath -> IO String+read_file_utf8 = fmap T.unpack . read_file_utf8_text++-- | 'read_file_utf8', or a default value if the file doesn't exist.+read_file_utf8_or :: String -> FilePath -> IO String+read_file_utf8_or def f = do+  x <- D.doesFileExist f+  if x then read_file_utf8 f else return def++-- | Write UTF8 string as file, via "Data.Text".+write_file_utf8 :: FilePath -> String -> IO ()+write_file_utf8 fn = B.writeFile fn . T.encodeUtf8 . T.pack++-- | 'readFile' variant using 'T.Text' for @ISO 8859-1@ (Latin 1) encoding.+read_file_iso_8859_1 :: FilePath -> IO String+read_file_iso_8859_1 = fmap (T.unpack . T.decodeLatin1) . B.readFile++-- | 'readFile' variant using 'T.Text' for local encoding.+read_file_locale :: FilePath -> IO String+read_file_locale = fmap T.unpack . T.readFile++-- | Interact with files.  Like Prelude.interact, but with named files.+interactWithFiles :: FilePath -> FilePath -> (String -> String) -> IO ()+interactWithFiles inputFile outputFile process = do+  input <- readFile inputFile+  writeFile outputFile (process input)++-- | Get line from stdin if there is any input, else Nothing.+getLineFromStdinIfReady :: IO (Maybe String)+getLineFromStdinIfReady = do+  r <- hReady stdin+  if r then fmap Just (hGetLine stdin) else return Nothing++-- | Wait for input to be available, and then get lines while input remains available.+getAvailableLinesFromStdin :: IO [String]+getAvailableLinesFromStdin = do+  _ <- hWaitForInput stdin (-1)+  Loop.unfoldM getLineFromStdinIfReady++-- | Interact with stdin and stdout.  Like Prelude.interact, but with pipes.+interactWithStdio :: (String -> String) -> IO ()+interactWithStdio strFunc = forever (getAvailableLinesFromStdin >>= \ln -> hPutStrLn stdout (strFunc (unlines ln)) >> hFlush stdout)

@@ -0,0 +1,1532 @@+-- | List functions.+module Music.Theory.List where++import Data.Bifunctor {- base -}+import Data.Function {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ord {- base -}++import qualified Data.IntMap as Map {- containers -}+import qualified Data.List.Ordered as O {- data-ordlist -}+import qualified Data.List.Split as S {- split -}+import qualified Data.Tree as Tree {- containers -}++import qualified Music.Theory.Either as T {- hmt-base -}++-- | 'Data.Vector.slice', ie. starting index (zero-indexed) and number of elements.+--+-- > slice 4 5 [1..] == [5,6,7,8,9]+slice :: Int -> Int -> [a] -> [a]+slice i n = take n . drop i++-- | Variant of slice with start and end indices (zero-indexed).+--+-- > section 4 8 [1..] == [5,6,7,8,9]+section :: Int -> Int -> [a] -> [a]+section l r = take (r - l + 1) . drop l++-- | Bracket sequence with left and right values.+--+-- > bracket ('<','>') "1,2,3" == "<1,2,3>"+bracket :: (a,a) -> [a] -> [a]+bracket (l,r) x = l : x ++ [r]++-- | Variant where brackets are sequences.+--+-- > bracket_l ("<:",":>") "1,2,3" == "<:1,2,3:>"+bracket_l :: ([a],[a]) -> [a] -> [a]+bracket_l (l,r) s = l ++ s ++ r++-- | The first & middle & last elements of a list.+--+-- > map unbracket_el ["","{12}"] == [(Nothing,"",Nothing),(Just '{',"12",Just '}')]+unbracket_el :: [a] -> (Maybe a,[a],Maybe a)+unbracket_el x =+    case x of+      [] -> (Nothing,[],Nothing)+      l:x' -> let (m,r) = separate_last' x' in (Just l,m,r)++-- | The first & middle & last elements of a list.+--+-- > map unbracket ["","{12}"] == [Nothing,Just ('{',"12",'}')]+unbracket :: [t] -> Maybe (t,[t],t)+unbracket x =+    case unbracket_el x of+      (Just l,m,Just r) -> Just (l,m,r)+      _ -> Nothing++-- | Erroring variant.+unbracket_err :: [t] -> (t,[t],t)+unbracket_err = fromMaybe (error "unbracket") . unbracket++-- * Split++-- | Relative of 'S.splitOn', but only makes first separation.+--+-- > splitOn "//" "lhs//rhs//rem" == ["lhs","rhs","rem"]+-- > separate_at "//" "lhs//rhs//rem" == Just ("lhs","rhs//rem")+separate_at :: Eq a => [a] -> [a] -> Maybe ([a],[a])+separate_at x =+    let n = length x+        f lhs rhs =+            if null rhs+            then Nothing+            else if x == take n rhs+                 then Just (reverse lhs,drop n rhs)+                 else f (head rhs : lhs) (tail rhs)+    in f []++-- | Variant of 'S.splitWhen' that keeps delimiters at left.+--+-- > split_when_keeping_left (== 'r') "rab rcd re rf r" == ["","rab ","rcd ","re ","rf ","r"]+split_when_keeping_left :: (a -> Bool) -> [a] -> [[a]]+split_when_keeping_left = S.split . S.keepDelimsL . S.whenElt++{- | Split before the indicated element, keeping it at the left of the sub-sequence it begins.+     'split_when_keeping_left' of '=='++> split_before 'x' "axbcxdefx" == ["a","xbc","xdef","x"]+> split_before 'x' "xa" == ["","xa"]++> map (flip split_before "abcde") "ae_" == [["","abcde"],["abcd","e"],["abcde"]]+> map (flip break "abcde" . (==)) "ae_" == [("","abcde"),("abcd","e"),("abcde","")]++> split_before 'r' "rab rcd re rf r" == ["","rab ","rcd ","re ","rf ","r"]+-}+split_before :: Eq a => a -> [a] -> [[a]]+split_before x = split_when_keeping_left (== x)++-- | Split before any of the indicated set of delimiters.+--+-- > split_before_any ",;" ";a,b,c;d;" == ["",";a",",b",",c",";d",";"]+split_before_any :: Eq a => [a] -> [a] -> [[a]]+split_before_any = S.split . S.keepDelimsL . S.oneOf++-- | Singleton variant of 'S.splitOn'.+--+-- > split_on_1 ":" "graph:layout" == Just ("graph","layout")+split_on_1 :: Eq t => [t] -> [t] -> Maybe ([t],[t])+split_on_1 e l =+    case S.splitOn e l of+      [p,q] -> Just (p,q)+      _ -> Nothing++-- | Erroring variant.+split_on_1_err :: Eq t => [t] -> [t] -> ([t],[t])+split_on_1_err e = fromMaybe (error "split_on_1") . split_on_1 e++-- | Split function that splits only once, ie. a variant of 'break'.+--+-- > split1 ' ' "three word sentence" == Just ("three","word sentence")+split1 :: Eq a => a -> [a] -> Maybe ([a],[a])+split1 c l =+    case break (== c) l of+      (lhs,_:rhs) -> Just (lhs,rhs)+      _ -> Nothing++-- | Erroring variant.+split1_err :: (Eq a, Show a) => a -> [a] -> ([a], [a])+split1_err e s = fromMaybe (error (show ("split1",e,s))) (split1 e s)++{- | If length is not even the second "half" is longer.++> split_into_halves [] == ([],[])+> split_into_halves [1] == ([],[1])+> split_into_halves [1 .. 2] == ([1],[2])+> split_into_halves [1 .. 8] == ([1,2,3,4],[5,6,7,8])+> split_into_halves [1 .. 9] == ([1,2,3,4],[5,6,7,8,9])+-}+split_into_halves :: [t] -> ([t], [t])+split_into_halves l =+  let n = length l `div` 2+      m = if n == 1 then 1 else n + (n `mod` 2) -- the two element list is a special case+  in (take m l, drop m l)++-- * Rotate++-- | Generic form of 'rotate_left'.+genericRotate_left :: Integral i => i -> [a] -> [a]+genericRotate_left n =+    let f (p,q) = q ++ p+    in f . genericSplitAt n++-- | Left rotation.+--+-- > rotate_left 1 [1..3] == [2,3,1]+-- > rotate_left 3 [1..5] == [4,5,1,2,3]+rotate_left :: Int -> [a] -> [a]+rotate_left = genericRotate_left++-- | Generic form of 'rotate_right'.+genericRotate_right :: Integral n => n -> [a] -> [a]+genericRotate_right n = reverse . genericRotate_left n . reverse++-- | Right rotation.+--+-- > rotate_right 1 [1..3] == [3,1,2]+rotate_right :: Int -> [a] -> [a]+rotate_right = genericRotate_right++{- | Rotate left by /n/ 'mod' /#p/ places.  Therefore negative n rotate right.++> rotate 1 [1..3] == [2,3,1]+> rotate 8 [1..5] == [4,5,1,2,3]+> (rotate (-1) "ABCD",rotate 1 "ABCD") == ("DABC","BCDA")+-}+rotate :: (Integral n) => n -> [a] -> [a]+rotate n p =+    let m = n `mod` genericLength p+    in genericRotate_left m p++-- | Rotate right by /n/ places.+--+-- > rotate_r 8 [1..5] == [3,4,5,1,2]+rotate_r :: (Integral n) => n -> [a] -> [a]+rotate_r = rotate . negate++-- | All rotations.+--+-- > rotations [0,1,3] == [[0,1,3],[1,3,0],[3,0,1]]+rotations :: [a] -> [[a]]+rotations p = map (`rotate_left` p) [0 .. length p - 1]++-- | Rotate list so that is starts at indicated element.+--+-- > rotate_starting_from 'c' "abcde" == Just "cdeab"+-- > rotate_starting_from '_' "abc" == Nothing+rotate_starting_from :: Eq a => a -> [a] -> Maybe [a]+rotate_starting_from x l =+    case break (== x) l of+      (_,[]) -> Nothing+      (lhs,rhs) -> Just (rhs ++ lhs)++-- | Erroring variant.+rotate_starting_from_err :: Eq a => a -> [a] -> [a]+rotate_starting_from_err x =+    fromMaybe (error "rotate_starting_from: non-element") .+    rotate_starting_from x++-- | Sequence of /n/ adjacent elements, moving forward by /k/ places.+-- The last element may have fewer than /n/ places, but will reach the+-- end of the input sequence.+--+-- > adj 3 2 "adjacent" == ["adj","jac","cen","nt"]+adj :: Int -> Int -> [a] -> [[a]]+adj n k l =+    case take n l of+      [] -> []+      r -> r : adj n k (drop k l)++-- | Variant of 'adj' where the last element has /n/ places but may+-- not reach the end of the input sequence.+--+-- > adj_trunc 4 1 "adjacent" == ["adja","djac","jace","acen","cent"]+-- > adj_trunc 3 2 "adjacent" == ["adj","jac","cen"]+adj_trunc :: Int -> Int -> [a] -> [[a]]+adj_trunc n k l =+    let r = take n l+    in if length r == n then r : adj_trunc n k (drop k l) else []++-- | 'adj_trunc' of 'close' by /n/-1.+--+-- > adj_cyclic_trunc 3 1 "adjacent" == ["adj","dja","jac","ace","cen","ent","nta","tad"]+adj_cyclic_trunc :: Int -> Int -> [a] -> [[a]]+adj_cyclic_trunc n k = adj_trunc n k . close (n - 1)++-- | Generic form of 'adj2'.+genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)]+genericAdj2 n l =+    case l of+      p:q:_ -> (p,q) : genericAdj2 n (genericDrop n l)+      _ -> []++-- | Adjacent elements of list, at indicated distance, as pairs.+--+-- > adj2 1 [1..5] == [(1,2),(2,3),(3,4),(4,5)]+-- > let l = [1..5] in zip l (tail l) == adj2 1 l+-- > adj2 2 [1..4] == [(1,2),(3,4)]+-- > adj2 3 [1..5] == [(1,2),(4,5)]+adj2 :: Int -> [t] -> [(t,t)]+adj2 = genericAdj2++-- | Append first /n/-elements to end of list.+--+-- > close 1 [1..3] == [1,2,3,1]+close :: Int -> [a] -> [a]+close k x = x ++ take k x++-- | 'adj2' '.' 'close' 1.+--+-- > adj2_cyclic 1 [1..3] == [(1,2),(2,3),(3,1)]+adj2_cyclic :: Int -> [t] -> [(t,t)]+adj2_cyclic n = adj2 n . close 1++-- | Adjacent triples.+--+-- > adj3 3 [1..6] == [(1,2,3),(4,5,6)]+adj3 :: Int -> [t] -> [(t,t,t)]+adj3 n l =+  case l of+      p:q:r:_ -> (p,q,r) : adj3 n (drop n l)+      _ -> []++-- | 'adj3' '.' 'close' 2.+--+-- > adj3_cyclic 1 [1..4] == [(1,2,3),(2,3,4),(3,4,1),(4,1,2)]+adj3_cyclic :: Int -> [t] -> [(t,t,t)]+adj3_cyclic n = adj3 n . close 2++{- | Adjacent quadruples.++> adj4 2 [1..8] == [(1,2,3,4),(3,4,5,6),(5,6,7,8)]+> adj4 4 [1..8] == [(1,2,3,4),(5,6,7,8)]+-}+adj4 :: Int -> [t] -> [(t,t,t,t)]+adj4 n l =+  case l of+      p:q:r:s:_ -> (p,q,r,s) : adj4 n (drop n l)+      _ -> []++-- | Interleave elements of /p/ and /q/.  If not of equal length elements are discarded.+--+-- > interleave [1..3] [4..6] == [1,4,2,5,3,6]+-- > interleave ".+-" "abc" == ".a+b-c"+-- > interleave [1..3] [] == []+interleave :: [a] -> [a] -> [a]+interleave p = concat . zipWith (\i j -> [i, j]) p -- concatMap (\(i, j) -> [i, j]) . zip p++-- | Interleave list of lists.  Allows lists to be of non-equal lenghts.+--+-- > interleave_set ["abcd","efgh","ijkl"] == "aeibfjcgkdhl"+-- > interleave_set ["abc","defg","hijkl"] == "adhbeicfjgkl"+interleave_set :: [[a]] -> [a]+interleave_set = concat . transpose++{-+import Safe {- safe -}++interleave_set l =+    case mapMaybe headMay l of+      [] -> []+      r -> r ++ interleave_set (mapMaybe tailMay l)+-}++-- | De-interleave /n/ lists.+--+-- > deinterleave 2 ".a+b-c" == [".+-","abc"]+-- > deinterleave 3 "aeibfjcgkdhl" == ["abcd","efgh","ijkl"]+deinterleave :: Int -> [a] -> [[a]]+deinterleave n = transpose . S.chunksOf n++-- | Special case for two-part deinterleaving.+--+-- > deinterleave2 ".a+b-c" == (".+-","abc")+deinterleave2 :: [t] -> ([t], [t])+deinterleave2 =+    let f l =+            case l of+              p:q:l' -> (p,q) : f l'+              _ -> []+    in unzip . f++{-+deinterleave2 =+    let f p q l =+            case l of+              [] -> (reverse p,reverse q)+              [a] -> (reverse (a:p),reverse q)+              a:b:l' -> rec (a:p) (b:q) l'+    in f [] []+-}++-- | Variant that continues with the longer input.+--+-- > interleave_continue ".+-" "abc" == ".a+b-c"+-- > interleave_continue [1..3] [] == [1..3]+-- > interleave_continue [] [1..3] == [1..3]+interleave_continue :: [a] -> [a] -> [a]+interleave_continue p q =+    case (p,q) of+      ([],_) -> q+      (_,[]) -> p+      (i:p',j:q') -> i : j : interleave_continue p' q'++-- | 'interleave' of 'rotate_left' by /i/ and /j/.+--+-- > interleave_rotations 9 3 [1..13] == [10,4,11,5,12,6,13,7,1,8,2,9,3,10,4,11,5,12,6,13,7,1,8,2,9,3]+interleave_rotations :: Int -> Int -> [b] -> [b]+interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s)++-- | 'unzip', apply /f1/ and /f2/ and 'zip'.+rezip :: ([t] -> [u]) -> ([v] -> [w]) -> [(t,v)] -> [(u,w)]+rezip f1 f2 l = let (p,q) = unzip l in zip (f1 p) (f2 q)++-- | Generalised histogram, with equality function for grouping and comparison function for sorting.+generic_histogram_by :: Integral i => (a -> a-> Bool) -> Maybe (a -> a-> Ordering) -> [a] -> [(a,i)]+generic_histogram_by eq_f cmp_f x =+    let g = groupBy eq_f (maybe x (`sortBy` x) cmp_f)+    in zip (map head g) (map genericLength g)++-- | Type specialised 'generic_histogram_by'.+histogram_by :: (a -> a-> Bool) -> Maybe (a -> a-> Ordering) -> [a] -> [(a,Int)]+histogram_by = generic_histogram_by++-- | Count occurences of elements in list, 'histogram_by' of '==' and 'compare'.+generic_histogram :: (Ord a,Integral i) => [a] -> [(a,i)]+generic_histogram = generic_histogram_by (==) (Just compare)++-- | Type specialised 'generic_histogram'.  Elements will be in ascending order.+--+-- > map histogram ["","hohoh","yxx"] == [[],[('h',3),('o',2)],[('x',2),('y',1)]]+histogram :: Ord a => [a] -> [(a,Int)]+histogram = generic_histogram++-- | Join two histograms, which must be sorted.+--+-- > histogram_join (zip "ab" [1,1]) (zip "bc" [1,1]) == zip "abc" [1,2,1]+histogram_join :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,Int)]+histogram_join p q =+  let f (e1,n1) (e2,n2) = if e1 == e2 then Just (e1,n1 + n2) else Nothing+  in case (p,q) of+       (_,[]) -> p+       ([],_) -> q+       (p1:p',q1:q') -> case f p1 q1 of+                          Just r -> r : histogram_join p' q'+                          Nothing -> if p1 < q1+                                     then p1 : histogram_join p' q+                                     else q1 : histogram_join p q'++-- | 'foldr' of 'histogram_join'.+--+-- > let f x = zip x (repeat 1) in histogram_merge (map f ["ab","bcd","de"]) == zip "abcde" [1,2,1,2,1]+histogram_merge :: Ord a => [[(a,Int)]] -> [(a,Int)]+histogram_merge = foldr histogram_join []++-- | Given (k,#) histogram where k is enumerable generate filled histogram with 0 for empty k.+--+-- > histogram_fill (histogram "histogram") == zip ['a'..'t'] [1,0,0,0,0,0,1,1,1,0,0,0,1,0,1,0,0,1,1,1]+histogram_fill :: (Ord a, Enum a) => [(a,Int)] -> [(a,Int)]+histogram_fill h =+  let k = map fst h+      e = [minimum k .. maximum k]+      f x = fromMaybe 0 (lookup x h)+  in zip e (map f e)++{- | Given two histograms p & q (sorted by key) make composite+histogram giving for all keys the counts for (p,q).++> r = zip "ABCDE" (zip [4,3,2,1,0] [2,3,4,0,5])+> histogram_composite (zip "ABCD" [4,3,2,1]) (zip "ABCE" [2,3,4,5]) == r+-}+histogram_composite :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,(Int,Int))]+histogram_composite p q =+  case (p,q) of+    ([],_) -> map (\(k,n) -> (k,(0,n))) q+    (_,[]) -> map (\(k,n) -> (k,(n,0))) p+    ((k1,n1):p',(k2,n2):q') -> case compare k1 k2 of+                                 LT -> (k1,(n1,0)) : histogram_composite p' q+                                 EQ -> (k1,(n1,n2)) : histogram_composite p' q'+                                 GT -> (k2,(0,n2)) : histogram_composite p q'++{- | Apply '-' at count of 'histogram_composite', ie. 0 indicates+equal number at p and q, negative indicates more elements at p than+q and positive more elements at q than p.++> histogram_diff (zip "ABCD" [4,3,2,1]) (zip "ABCE" [2,3,4,5]) == zip "ABCDE" [-2,0,2,-1,5]+-}+histogram_diff :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,Int)]+histogram_diff p = map (\(k,(n,m)) -> (k,m - n)) . histogram_composite p++-- | Elements that appear more than once in the input given equality predicate.+duplicates_by :: Ord a => (a -> a -> Bool) -> [a] -> [a]+duplicates_by f = map fst . filter (\(_,n) -> n > 1) . histogram_by f (Just compare)++-- | 'duplicates_by' of '=='.+--+-- > map duplicates ["duplicates","redundant"] == ["","dn"]+duplicates :: Ord a => [a] -> [a]+duplicates = duplicates_by (==)++-- | List segments of length /i/ at distance /j/.+--+-- > segments 2 1 [1..5] == [[1,2],[2,3],[3,4],[4,5]]+-- > segments 2 2 [1..5] == [[1,2],[3,4]]+segments :: Int -> Int -> [a] -> [[a]]+segments i j p =+    let q = take i p+        p' = drop j p+    in if length q /= i then [] else q : segments i j p'++-- | 'foldl1' 'intersect'.+--+-- > intersect_l [[1,2],[1,2,3],[1,2,3,4]] == [1,2]+intersect_l :: Eq a => [[a]] -> [a]+intersect_l = foldl1 intersect++-- | 'foldl1' 'union'.+--+-- > sort (union_l [[1,3],[2,3],[3]]) == [1,2,3]+union_l :: Eq a => [[a]] -> [a]+union_l = foldl1 union++-- | Intersection of adjacent elements of list at distance /n/.+--+-- > adj_intersect 1 [[1,2],[1,2,3],[1,2,3,4]] == [[1,2],[1,2,3]]+adj_intersect :: Eq a => Int -> [[a]] -> [[a]]+adj_intersect n = map intersect_l . segments 2 n++-- | List of cycles at distance /n/.+--+-- > cycles 2 [1..6] == [[1,3,5],[2,4,6]]+-- > cycles 3 [1..9] == [[1,4,7],[2,5,8],[3,6,9]]+-- > cycles 4 [1..8] == [[1,5],[2,6],[3,7],[4,8]]+cycles :: Int -> [a] -> [[a]]+cycles n = transpose . S.chunksOf n++-- | Variant of 'filter' that has a predicate to halt processing,+-- ie. 'filter' of 'takeWhile'.+--+-- > filter_halt (even . fst) ((< 5) . snd) (zip [1..] [0..])+filter_halt :: (a -> Bool) -> (a -> Bool) -> [a] -> [a]+filter_halt sel end = filter sel . takeWhile end++-- | Variant of 'Data.List.filter' that retains 'Nothing' as a+-- placeholder for removed elements.+--+-- > filter_maybe even [1..4] == [Nothing,Just 2,Nothing,Just 4]+filter_maybe :: (a -> Bool) -> [a] -> [Maybe a]+filter_maybe f = map (\e -> if f e then Just e else Nothing)++{- | Select only the elements from the list that lie in the indicated range, which is (inclusive, exclusive).++> filterInRange (3, 5) [1, 1.5 .. 9] == [3.0,3.5,4.0,4.5]+-}+filterInRange :: Ord a => (a, a) -> [a] -> [a]+filterInRange (lhs, rhs) = filter (\n -> n >= lhs && n < rhs)++-- | Replace all /p/ with /q/ in /s/.+--+-- > replace "_x_" "-X-" "an _x_ string" == "an -X- string"+-- > replace "ab" "cd" "ab ab cd ab" == "cd cd cd cd"+replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace p q s =+    let n = length p+    in case s of+         [] -> []+         c:s' -> if p `isPrefixOf` s+                 then q ++ replace p q (drop n s)+                 else c : replace p q s'++-- | Replace the /i/th value at /ns/ with /x/.+--+-- > replace_at "test" 2 'n' == "tent"+replace_at :: Integral i => [a] -> i -> a -> [a]+replace_at ns i x =+    let f j y = if i == j then x else y+    in zipWith f [0..] ns++-- | Data.List.stripPrefix, which however hugs doesn't know of.+strip_prefix :: Eq a => [a] -> [a] -> Maybe [a]+strip_prefix lhs rhs =+  case (lhs,rhs) of+    ([], ys) -> Just ys+    (_, []) -> Nothing+    (x:xs, y:ys) -> if x == y then strip_prefix xs ys else Nothing++-- | 'error' of 'stripPrefix'+strip_prefix_err :: Eq t => [t] -> [t] -> [t]+strip_prefix_err pfx = fromMaybe (error "strip_prefix") . strip_prefix pfx++-- * Association lists++-- | Equivalent to 'groupBy' /eq/ 'on' /f/.+--+-- > group_by_on (==) snd (zip [0..] "abbc") == [[(0,'a')],[(1,'b'),(2,'b')],[(3,'c')]]+group_by_on :: (x -> x -> Bool) -> (t -> x) -> [t] -> [[t]]+group_by_on eq f = groupBy (eq `on` f)++-- | 'group_by_on' of '=='.+--+-- > r = [[(1,'a'),(1,'b')],[(2,'c')],[(3,'d'),(3,'e')],[(4,'f')]]+-- > group_on fst (zip [1,1,2,3,3,4] "abcdef") == r+group_on :: Eq x => (a -> x) -> [a] -> [[a]]+group_on = group_by_on (==)++-- | Given an equality predicate and accesors for /key/ and /value/ collate adjacent values.+collate_by_on_adjacent :: (k -> k -> Bool) -> (a -> k) -> (a -> v) -> [a] -> [(k,[v])]+collate_by_on_adjacent eq f g =+    let h l = case l of+                [] -> error "collate_by_on_adjacent"+                l0:_ -> (f l0,map g l)+    in map h . group_by_on eq f++-- | 'collate_by_on_adjacent' of '=='+collate_on_adjacent :: Eq k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]+collate_on_adjacent = collate_by_on_adjacent (==)++-- | 'collate_on_adjacent' of 'fst' and 'snd'.+--+-- > collate_adjacent (zip "TDD" "xyz") == [('T',"x"),('D',"yz")]+collate_adjacent :: Eq a => [(a,b)] -> [(a,[b])]+collate_adjacent = collate_on_adjacent fst snd++-- | Data.List.sortOn, which however hugs doesn't know of.+sort_on :: Ord b => (a -> b) -> [a] -> [a]+sort_on f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))++-- | 'sortOn' prior to 'collate_on_adjacent'.+--+-- > r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")]+-- > collate_on fst snd (zip "ABCBCD" "abcdef") == r+collate_on :: Ord k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]+collate_on f g = collate_on_adjacent f g . sort_on f++-- | 'collate_on' of 'fst' and 'snd'.+--+-- > collate (zip "TDD" "xyz") == [('D',"yz"),('T',"x")]+-- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")]+collate :: Ord a => [(a,b)] -> [(a,[b])]+collate = collate_on fst snd++-- | Reverse of 'collate', inverse if order is not considered.+--+-- > uncollate [(1,"ac"),(2,"b")] == zip [1,1,2] "acb"+uncollate :: [(k,[v])] -> [(k,v)]+uncollate = concatMap (\(k,v) -> zip (repeat k) v)++-- | Make /assoc/ list with given /key/.+--+-- > with_key 'a' [1..3] == [('a',1),('a',2),('a',3)]+with_key :: k -> [v] -> [(k,v)]+with_key h = zip (repeat h)++-- | Left biased merge of association lists /p/ and /q/.+--+-- > assoc_merge [(5,"a"),(3,"b")] [(5,"A"),(7,"C")] == [(5,"a"),(3,"b"),(7,"C")]+assoc_merge :: Eq k => [(k,v)] -> [(k,v)] -> [(k,v)]+assoc_merge p q =+    let p_k = map fst p+        q' = filter ((`notElem` p_k) . fst) q+    in p ++ q'++-- | Keys are in ascending order, the entry retrieved is the rightmose with+--   a key less than or equal to the key requested.+--   If the key requested is less than the initial key, or the list is empty, returns 'Nothing'.+--+-- > let m = [(1,'a'),(4,'x'),(4,'b'),(5,'c')]+-- > mapMaybe (ord_map_locate m) [1 .. 6] == [(1,'a'),(1,'a'),(1,'a'),(4,'b'),(5,'c'),(5,'c')]+-- > ord_map_locate m 0 == Nothing+ord_map_locate :: Ord k => [(k,v)] -> k -> Maybe (k,v)+ord_map_locate mp i =+    let f (k0,v0) xs =+          case xs of+            [] -> if i >= k0 then Just (k0,v0) else error "ord_map_locate?"+            ((k1,v1):xs') -> if i >= k0 && i < k1 then Just (k0,v0) else f (k1,v1) xs'+    in case mp of+         [] -> Nothing+         (k0,v0):mp' -> if i < k0 then Nothing else f (k0,v0) mp'++-- * Δ++-- | Intervals to values, zero is /n/.+--+-- > dx_d 5 [1,2,3] == [5,6,8,11]+dx_d :: (Num a) => a -> [a] -> [a]+dx_d = scanl (+)++-- | Variant that takes initial value and separates final value.  This+-- is an appropriate function for 'mapAccumL'.+--+-- > dx_d' 5 [1,2,3] == (11,[5,6,8])+-- > dx_d' 0 [1,1,1] == (3,[0,1,2])+dx_d' :: Num t => t -> [t] -> (t,[t])+dx_d' n l =+    case reverse (scanl (+) n l) of+      e:r -> (e,reverse r)+      _ -> error "dx_d'"++-- | Integration with /f/, ie. apply flip of /f/ between elements of /l/.+--+-- > d_dx_by (,) "abcd" == [('b','a'),('c','b'),('d','c')]+-- > d_dx_by (-) [0,2,4,1,0] == [2,2,-3,-1]+-- > d_dx_by (-) [2,3,0,4,1] == [1,-3,4,-3]+d_dx_by :: (t -> t -> u) -> [t] -> [u]+d_dx_by f l = if null l then [] else zipWith f (tail l) l++-- | Integrate, 'd_dx_by' '-', ie. pitch class segment to interval sequence.+--+-- > d_dx [5,6,8,11] == [1,2,3]+-- > d_dx [] == []+d_dx :: (Num a) => [a] -> [a]+d_dx = d_dx_by (-)++-- | Elements of /p/ not in /q/.+--+-- > [1,2,3] `difference` [1,2] == [3]+difference :: Eq a => [a] -> [a] -> [a]+difference p q = filter (`notElem` q) p++-- | Is /p/ a subset of /q/, ie. is 'intersect' of /p/ and /q/ '==' /p/.+--+-- > map (is_subset [1,2]) [[1],[1,2],[1,2,3]] == [False,True,True]+is_subset :: Eq a => [a] -> [a] -> Bool+is_subset p q = p `intersect` q == p++-- | Is /p/ a proper subset of /q/, 'is_subset' and 'not' equal.+--+-- > map (is_proper_subset [1,2]) [[1],[1,2],[1,2,3]] == [False,False,True]+is_proper_subset :: Eq a => [a] -> [a] -> Bool+is_proper_subset p q = is_subset p q && p /= p `union` q++-- | Is /p/ a superset of /q/, ie. 'flip' 'is_subset'.+--+-- > is_superset [1,2,3] [1,2] == True+is_superset :: Eq a => [a] -> [a] -> Bool+is_superset = flip is_subset++-- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'.+--+-- > subsequence [1,2] [1,2,3] == True+subsequence :: Eq a => [a] -> [a] -> Bool+subsequence = isInfixOf++-- | Erroring variant of 'findIndex'.+findIndex_err :: (a -> Bool) -> [a] -> Int+findIndex_err f = fromMaybe (error "findIndex?") . findIndex f++-- | Erroring variant of 'elemIndex'.+elemIndex_err :: Eq a => a -> [a] -> Int+elemIndex_err x = fromMaybe (error "ix_of") . elemIndex x++-- | Variant of 'elemIndices' that requires /e/ to be unique in /p/.+--+-- > elem_index_unique 'a' "abcda" == undefined+elem_index_unique :: Eq a => a -> [a] -> Int+elem_index_unique e p =+    case elemIndices e p of+      [i] -> i+      _ -> error "elem_index_unique"++-- | Lookup that errors and prints message and key.+lookup_err_msg :: (Eq k,Show k) => String -> k -> [(k,v)] -> v+lookup_err_msg err k = fromMaybe (error (err ++ ": " ++ show k)) . lookup k++-- | Error variant.+lookup_err :: Eq k => k -> [(k,v)] -> v+lookup_err n = fromMaybe (error "lookup") . lookup n++-- | 'lookup' variant with default value.+lookup_def :: Eq k => k -> v -> [(k,v)] -> v+lookup_def k d = fromMaybe d . lookup k++-- | If /l/ is empty 'Nothing', else 'Just' /l/.+non_empty :: [t] -> Maybe [t]+non_empty l = if null l then Nothing else Just l++-- | Variant on 'filter' that selects all matches.+--+-- > lookup_set 1 (zip [1,2,3,4,1] "abcde") == Just "ae"+lookup_set :: Eq k => k -> [(k,v)] -> Maybe [v]+lookup_set k = non_empty . map snd . filter ((== k) . fst)++-- | Erroring variant.+lookup_set_err :: Eq k => k -> [(k,v)] -> [v]+lookup_set_err k = fromMaybe (error "lookup_set?") . lookup_set k++-- | Reverse lookup.+--+-- > reverse_lookup 'c' [] == Nothing+-- > reverse_lookup 'b' (zip [1..] ['a'..]) == Just 2+-- > lookup 2 (zip [1..] ['a'..]) == Just 'b'+reverse_lookup :: Eq v => v -> [(k,v)] -> Maybe k+reverse_lookup k = fmap fst . find ((== k) . snd)++-- | Erroring variant.+reverse_lookup_err :: Eq v => v -> [(k,v)] -> k+reverse_lookup_err k = fromMaybe (error "reverse_lookup") . reverse_lookup k++{-+reverse_lookup :: Eq b => b -> [(a,b)] -> Maybe a+reverse_lookup key ls =+    case ls of+      [] -> Nothing+      (x,y):ls' -> if key == y then Just x else reverse_lookup key ls'+-}++-- | Erroring variant of 'find'.+find_err :: (t -> Bool) -> [t] -> t+find_err f = fromMaybe (error "find") . find f++-- | Basis of 'find_bounds_scl', indicates if /x/ is to the left or+-- right of the list, and if to the right whether equal or not.+-- 'Right' values will be correct if the list is not ascending,+-- however 'Left' values only make sense for ascending ranges.+--+-- > map (find_bounds_cmp compare [(0,1),(1,2)]) [-1,0,1,2,3]+find_bounds_cmp :: (t -> s -> Ordering) -> [(t,t)] -> s -> Either ((t,t),Ordering) (t,t)+find_bounds_cmp f l x =+    let g (p,q) = f p x /= GT && f q x == GT+    in case l of+         [] -> error "find_bounds_cmp: nil"+         [(p,q)] -> if g (p,q) then Right (p,q) else Left ((p,q),f q x)+         (p,q):l' -> if f p x == GT+                     then Left ((p,q),GT)+                     else if g (p,q) then Right (p,q) else find_bounds_cmp f l' x++-- | Decide if value is nearer the left or right value of a range, return 'fst' or 'snd'.+decide_nearest_f :: Ord o => Bool -> (p -> o) -> (p,p) -> ((x,x) -> x)+decide_nearest_f bias_left f (p,q) =+  case compare (f p) (f q) of+    LT -> fst+    EQ -> if bias_left then fst else snd+    GT -> snd++-- | 'decide_nearest_f' with 'abs' of '-' as measure.+--+-- > (decide_nearest True 2 (1,3)) ("left","right") == "left"+decide_nearest :: (Num o,Ord o) => Bool -> o -> (o,o) -> ((x,x) -> x)+decide_nearest bias_left x = decide_nearest_f bias_left (abs . (x -))++-- | /sel_f/ gets comparison key from /t/.+find_nearest_by :: (Ord n,Num n) => (t -> n) -> Bool -> [t] -> n -> t+find_nearest_by sel_f bias_left l x =+  let cmp_f i j = compare (sel_f i) j+  in case find_bounds_cmp cmp_f (adj2 1 l) x of+       Left ((p,_),GT) -> p+       Left ((_,q),_) -> q+       Right (p,q) -> decide_nearest bias_left x (sel_f p,sel_f q) (p,q)++-- | Find the number that is nearest the requested value in an+-- ascending list of numbers.+--+-- > map (find_nearest_err True [0,3.5,4,7]) [-1,1,3,5,7,9] == [0,0,3.5,4,7,7]+find_nearest_err :: (Num n,Ord n) => Bool -> [n] -> n -> n+find_nearest_err = find_nearest_by id++-- | 'find_nearest_err' allowing 'null' input list (which returns 'Nothing')+find_nearest :: (Num n,Ord n) => Bool -> [n] -> n -> Maybe n+find_nearest bias_left l x = if null l then Nothing else Just (find_nearest_err bias_left l x)++-- | Basis of 'find_bounds'.  There is an option to consider the last+-- element specially, and if equal to the last span is given.+--+-- scl=special-case-last+find_bounds_scl :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t)+find_bounds_scl scl f l x =+    case find_bounds_cmp f l x of+         Right r -> Just r+         Left (r,EQ) -> if scl then Just r else Nothing+         _ -> Nothing++-- | Find adjacent elements of list that bound element under given comparator.+--+-- > let {f = find_bounds True compare [1..5]+-- >     ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]}+-- > in map f [0,1,3.5,5] == r+find_bounds :: Bool -> (t -> s -> Ordering) -> [t] -> s -> Maybe (t,t)+find_bounds scl f l = find_bounds_scl scl f (adj2 1 l)++-- | Special case of 'dropRight'.+--+-- > map drop_last ["","?","remove"] == ["","","remov"]+drop_last :: [t] -> [t]+drop_last l =+    case l of+      [] -> []+      [_] -> []+      e:l' -> e : drop_last l'++-- | Variant of 'drop' from right of list.+--+-- > dropRight 1 [1..9] == [1..8]+dropRight :: Int -> [a] -> [a]+dropRight n = reverse . drop n . reverse++-- | Variant of 'dropWhile' from right of list.+--+-- > dropWhileRight Data.Char.isDigit "A440" == "A"+dropWhileRight :: (a -> Bool) -> [a] -> [a]+dropWhileRight p = reverse . dropWhile p . reverse++-- | Data.List.dropWhileEnd, which however hugs doesn't know of.+drop_while_end :: (a -> Bool) -> [a] -> [a]+drop_while_end p = foldr (\x xs -> if p x && null xs then [] else x : xs) []++{- | 'foldr' form of 'dropWhileRight'.++> drop_while_right Data.Char.isDigit "A440" == "A"+-}+drop_while_right :: (a -> Bool) -> [a] -> [a]+drop_while_right p = foldr (\x xs -> if p x && null xs then [] else x:xs) []++-- | 'take' from right.+--+-- > take_right 3 "taking" == "ing"+take_right :: Int -> [a] -> [a]+take_right n = reverse . take n . reverse++-- | 'takeWhile' from right.+--+-- > takeWhileRight Data.Char.isDigit "A440" == "440"+takeWhileRight :: (a -> Bool) -> [a] -> [a]+takeWhileRight p = reverse . takeWhile p . reverse++{- | 'foldr' form of 'takeWhileRight'.++> take_while_right Data.Char.isDigit "A440" == "440"+-}+take_while_right :: (a -> Bool) -> [a] -> [a]+take_while_right p =+  snd .+  foldr (\x xys -> (if p x && fst xys then bimap id (x:) else bimap (const False) id) xys) (True, [])++-- | Variant of 'take' that allows 'Nothing' to indicate the complete list.+--+-- > maybe_take (Just 5) [1 .. ] == [1 .. 5]+-- > maybe_take Nothing [1 .. 9] == [1 .. 9]+maybe_take :: Maybe Int -> [a] -> [a]+maybe_take n l = maybe l (`take` l) n++{- | Take until /f/ is true.  This is not the same as 'not' at+     'takeWhile' because it keeps the last element. It is an error+     if the predicate never succeeds.++> take_until (== 'd') "tender" == "tend"+> takeWhile (not . (== 'd')) "tend" == "ten"+> take_until (== 'd') "seven" == undefined+-}+take_until :: (a -> Bool) -> [a] -> [a]+take_until f l =+  case l of+    [] -> error "take_until?"+    e:l' -> if f e then [e] else e : take_until f l'++-- | Apply /f/ at first element, and /g/ at all other elements.+--+-- > at_head negate id [1..5] == [-1,2,3,4,5]+at_head :: (a -> b) -> (a -> b) -> [a] -> [b]+at_head f g x =+    case x of+      [] -> []+      e:x' -> f e : map g x'++-- | Apply /f/ at all but last element, and /g/ at last element.+--+-- > at_last (* 2) negate [1..4] == [2,4,6,-4]+at_last :: (a -> b) -> (a -> b) -> [a] -> [b]+at_last f g x =+    case x of+      [] -> []+      [i] -> [g i]+      i:x' -> f i : at_last f g x'++-- | Separate list into an initial list and perhaps the last element tuple.+--+-- > separate_last' [] == ([],Nothing)+separate_last' :: [a] -> ([a],Maybe a)+separate_last' x =+    case reverse x of+      [] -> ([],Nothing)+      e:x' -> (reverse x',Just e)++-- | Error on null input.+--+-- > separate_last [1..5] == ([1..4],5)+separate_last :: [a] -> ([a],a)+separate_last = fmap (fromMaybe (error "separate_last")) . separate_last'++-- | Replace directly repeated elements with 'Nothing'.+--+-- > indicate_repetitions "abba" == [Just 'a',Just 'b',Nothing,Just 'a']+indicate_repetitions :: Eq a => [a] -> [Maybe a]+indicate_repetitions =+    let f l = case l of+                [] -> []+                e:l' -> Just e : map (const Nothing) l'+    in concatMap f . group++-- | 'zipWith' of list and it's own tail.+--+-- > zip_with_adj (,) "abcde" == [('a','b'),('b','c'),('c','d'),('d','e')]+zip_with_adj :: (a -> a -> b) -> [a] -> [b]+zip_with_adj f xs = zipWith f xs (tail xs)++-- | Type-specialised 'zip_with_adj'.+compare_adjacent_by :: (a -> a -> Ordering) -> [a] -> [Ordering]+compare_adjacent_by = zip_with_adj++-- | 'compare_adjacent_by' of 'compare'.+--+-- > compare_adjacent [0,1,3,2] == [LT,LT,GT]+compare_adjacent :: Ord a => [a] -> [Ordering]+compare_adjacent = compare_adjacent_by compare++-- | Head and tail of list.  Useful to avoid "incomplete-uni-patterns" warnings.  It's an error if the list is empty.+headTail :: [a] -> (a, [a])+headTail l = (head l, tail l)++-- | First and second elements of list. Useful to avoid "incomplete-uni-patterns" warnings.  It's an error if the list has less than two elements.+firstSecond :: [t] -> (t, t)+firstSecond l = (l !! 0, l !! 1)++-- | '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') = headTail r+                in if f x y+                   then (x:r0) : r'+                   else [x] : r++-- | Reduce sequences of consecutive values to ranges.+--+-- > group_ranges [-1,0,3,4,5,8,9,12] == [(-1,0),(3,5),(8,9),(12,12)]+-- > group_ranges [3,2,3,4,3] == [(3,3),(2,4),(3,3)]+group_ranges :: (Num t, Eq t) => [t] -> [(t,t)]+group_ranges =+    let f l = (head l,last l)+    in map f . adjacent_groupBy (\p q -> p + 1 == q)++-- | 'groupBy' on /structure/ of 'Maybe', ie. all 'Just' compare equal.+--+-- > let r = [[Just 1],[Nothing,Nothing],[Just 4,Just 5]]+-- > in group_just [Just 1,Nothing,Nothing,Just 4,Just 5] == r+group_just :: [Maybe a] -> [[Maybe a]]+group_just = group_on isJust++-- | Predicate to determine if all elements of the list are '=='.+--+-- > all_equal "aaa" == True+all_equal :: Eq a => [a] -> Bool+all_equal l =+    case l of+      [] -> True+      [_] -> True+      x:xs -> all (== x) xs++-- | Variant using 'nub'.+all_eq :: Eq n => [n] -> Bool+all_eq = (== 1) . length . nub++-- | 'nubBy' '==' 'on' /f/.+--+-- > nub_on snd (zip "ABCD" "xxyy") == [('A','x'),('C','y')]+nub_on :: Eq b => (a -> b) -> [a] -> [a]+nub_on f = nubBy ((==) `on` f)++-- | 'group_on' of 'sortOn'.+--+-- > let r = [[('1','a'),('1','c')],[('2','d')],[('3','b'),('3','e')]]+-- > in sort_group_on fst (zip "13123" "abcde") == r+sort_group_on :: Ord b => (a -> b) -> [a] -> [[a]]+sort_group_on f = group_on f . sort_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++-- | Cons onto end of list.+--+-- > snoc 4 [1,2,3] == [1,2,3,4]+snoc :: a -> [a] -> [a]+snoc e l = l ++ [e]++-- * Ordering++-- | Comparison function type.+type Compare_F a = a -> a -> Ordering++-- | If /f/ compares 'EQ', defer to /g/.+two_stage_compare :: Compare_F a -> Compare_F a -> Compare_F a+two_stage_compare f g p q =+    case f p q of+      EQ -> g p q+      r -> r++-- | 'compare' 'on' of 'two_stage_compare'+two_stage_compare_on :: (Ord i, Ord j) => (t -> i) -> (t -> j) -> t -> t -> Ordering+two_stage_compare_on f g = two_stage_compare (compare `on` f) (compare `on` g)++-- | Sequence of comparison functions, continue comparing until not EQ.+--+-- > compare (1,0) (0,1) == GT+-- > n_stage_compare [compare `on` snd,compare `on` fst] (1,0) (0,1) == LT+n_stage_compare :: [Compare_F a] -> Compare_F a+n_stage_compare l p q =+    case l of+      [] -> EQ+      f:l' -> case f p q of+                EQ -> n_stage_compare l' p q+                r -> r++-- | 'compare' 'on' of 'two_stage_compare'+n_stage_compare_on :: Ord i => [t -> i] -> t -> t -> Ordering+n_stage_compare_on l = n_stage_compare (map (compare `on`) l)++-- | Sort sequence /a/ based on ordering of sequence /b/.+--+-- > sort_to "abc" [1,3,2] == "acb"+-- > sort_to "adbce" [1,4,2,3,5] == "abcde"+sort_to :: Ord i => [e] -> [i] -> [e]+sort_to e = map fst . sort_on snd . zip e++-- | 'flip' of 'sort_to'.+--+-- > sort_to_rev [1,4,2,3,5] "adbce" == "abcde"+sort_to_rev :: Ord i => [i] -> [e] -> [e]+sort_to_rev = flip sort_to++-- | 'sortBy' of 'two_stage_compare'.+sort_by_two_stage :: Compare_F a -> Compare_F a -> [a] -> [a]+sort_by_two_stage f g = sortBy (two_stage_compare f g)++-- | 'sortBy' of 'n_stage_compare'.+sort_by_n_stage :: [Compare_F a] -> [a] -> [a]+sort_by_n_stage f = sortBy (n_stage_compare f)++-- | 'sortBy' of 'two_stage_compare_on'.+sort_by_two_stage_on :: (Ord b,Ord c) => (a -> b) -> (a -> c) -> [a] -> [a]+sort_by_two_stage_on f g = sortBy (two_stage_compare_on f g)++-- | 'sortBy' of 'n_stage_compare_on'.+sort_by_n_stage_on :: Ord b => [a -> b] -> [a] -> [a]+sort_by_n_stage_on f = sortBy (n_stage_compare_on f)++-- | Given a comparison function, merge two ascending lists. Alias for 'O.mergeBy'+--+-- > merge_by compare [1,3,5] [2,4] == [1..5]+merge_by :: Compare_F a -> [a] -> [a] -> [a]+merge_by = O.mergeBy++-- | 'merge_by' 'compare' 'on'.+merge_on :: Ord x => (a -> x) -> [a] -> [a] -> [a]+merge_on f = merge_by (compare `on` f)++-- | 'O.mergeBy' of 'two_stage_compare'.+merge_by_two_stage :: Ord b => (a -> b) -> Compare_F c -> (a -> c) -> [a] -> [a] -> [a]+merge_by_two_stage f cmp g = O.mergeBy (two_stage_compare (compare `on` f) (cmp `on` g))++-- | Alias for 'O.merge'+merge :: Ord a => [a] -> [a] -> [a]+merge = O.merge++-- | Merge list of sorted lists given comparison function.  Note that+-- this is not equal to 'O.mergeAll'.+merge_set_by :: (a -> a -> Ordering) -> [[a]] -> [a]+merge_set_by f = foldr (merge_by f) []++-- | 'merge_set_by' of 'compare'.+--+-- > merge_set [[1,3,5,7,9],[2,4,6,8],[10]] == [1..10]+merge_set :: Ord a => [[a]] -> [a]+merge_set = merge_set_by compare++{-| 'merge_by' variant that joins (resolves) equal elements.++> let {left p _ = p+>     ;right _ q = q+>     ;cmp = compare `on` fst+>     ;p = zip [1,3,5] "abc"+>     ;q = zip [1,2,3] "ABC"+>     ;left_r = [(1,'a'),(2,'B'),(3,'b'),(5,'c')]+>     ;right_r = [(1,'A'),(2,'B'),(3,'C'),(5,'c')]}+> in merge_by_resolve left cmp p q == left_r &&+>    merge_by_resolve right cmp p q == right_r++> merge_by_resolve (\x _ -> x) (compare `on` fst) [(0,'A'),(1,'B'),(4,'E')] (zip [1..] "bcd")+-}+merge_by_resolve :: (a -> a -> a) -> Compare_F a -> [a] -> [a] -> [a]+merge_by_resolve jn cmp =+    let recur p q =+            case (p,q) of+              ([],_) -> q+              (_,[]) -> p+              (l:p',r:q') -> case cmp l r of+                               LT -> l : recur p' q+                               EQ -> jn l r : recur p' q'+                               GT -> r : recur p q'+    in recur++-- | Merge two sorted (ascending) sequences.+--   Where elements compare equal, select element from left input.+--+-- > asc_seq_left_biased_merge_by (compare `on` fst) [(0,'A'),(1,'B'),(4,'E')] (zip [1..] "bcd")+asc_seq_left_biased_merge_by :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+asc_seq_left_biased_merge_by = merge_by_resolve const++-- | Find the first two adjacent elements for which /f/ is True.+--+-- > find_adj (>) [1,2,3,3,2,1] == Just (3,2)+-- > find_adj (>=) [1,2,3,3,2,1] == Just (3,3)+find_adj :: (a -> a -> Bool) -> [a] -> Maybe (a,a)+find_adj f xs =+    case xs of+      p:q:xs' -> if f p q then Just (p,q) else find_adj f (q:xs')+      _ -> Nothing++-- | 'find_adj' of '>='+--+-- > filter is_ascending (words "A AA AB ABB ABC ABA") == words "A AB ABC"+is_ascending :: Ord a => [a] -> Bool+is_ascending = isNothing . find_adj (>=)++-- | 'find_adj' of '>'+--+-- > filter is_non_descending (words "A AA AB ABB ABC ABA") == ["A","AA","AB","ABB","ABC"]+is_non_descending :: Ord a => [a] -> Bool+is_non_descending = isNothing . find_adj (>)++-- | Variant of `elem` that operates on a sorted list, halting.+--   This is 'O.member'.+--+-- > 16 `elem_ordered` [1,3 ..] == False+-- > 16 `elem` [1,3 ..] == undefined+elem_ordered :: Ord t => t -> [t] -> Bool+elem_ordered = O.member++-- | Variant of `elemIndex` that operates on a sorted list, halting.+--+-- > 16 `elemIndex_ordered` [1,3 ..] == Nothing+-- > 16 `elemIndex_ordered` [0,1,4,9,16,25,36,49,64,81,100] == Just 4+elemIndex_ordered :: Ord t => t -> [t] -> Maybe Int+elemIndex_ordered e =+    let recur k l =+            case l of+              [] -> Nothing+              x:l' -> if e == x+                      then Just k+                      else if x > e+                           then Nothing+                           else recur (k + 1) l'+    in recur 0++-- | 'zipWith' variant equivalent to 'mapMaybe' (ie. 'catMaybes' of 'zipWith')+zip_with_maybe :: (a -> b -> Maybe c) -> [a] -> [b] -> [c]+zip_with_maybe f lhs = catMaybes . zipWith f lhs++-- | 'zipWith' variant that extends shorter side using given value.+zip_with_ext :: t -> u -> (t -> u -> v) -> [t] -> [u] -> [v]+zip_with_ext i j f p q =+  case (p,q) of+    ([],_) -> map (f i) q+    (_,[]) -> map (`f` j) p+    (x:p',y:q') -> f x y : zip_with_ext i j f p' q'++{- | 'zip_with_ext' of ','++> let f = zip_ext 'i' 'j'+> f "" "" == []+> f "p" "" == zip "p" "j"+> f "" "q" == zip "i" "q"+> f "pp" "q" == zip "pp" "qj"+> f "p" "qq" == zip "pi" "qq"+-}+zip_ext :: t -> u -> [t] -> [u] -> [(t,u)]+zip_ext i j = zip_with_ext i j (,)++-- | Keep right variant of 'zipWith', where unused rhs values are returned.+--+-- > zip_with_kr (,) [1..3] ['a'..'e'] == ([(1,'a'),(2,'b'),(3,'c')],"de")+zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])+zip_with_kr f =+    let go r p q =+            case (p,q) of+              (i:p',j:q') -> go (f i j : r) p' q'+              _ -> (reverse r,q)+    in go []++-- | A 'zipWith' variant that always consumes an element from the left+-- hand side (lhs), but only consumes an element from the right hand+-- side (rhs) if the zip function is 'Right' and not if 'Left'.+-- There's also a secondary function to continue if the rhs ends+-- before the lhs.+zip_with_perhaps_rhs :: (a -> b -> Either c c) -> (a -> c) -> [a] -> [b] -> [c]+zip_with_perhaps_rhs f g lhs rhs =+    case (lhs,rhs) of+      ([],_) -> []+      (_,[]) -> map g lhs+      (p:lhs',q:rhs') -> case f p q of+                           Left r -> r : zip_with_perhaps_rhs f g lhs' rhs+                           Right r -> r : zip_with_perhaps_rhs f g lhs' rhs'++{- | Zip a list with a list of lists.+Ordinarily the list has at least as many elements as there are elements at the list of lists.+There is also a Traversable form of this called 'adopt_shape_2_zip_stream'.++> zip_list_with_list_of_list [1 ..] ["a", "list", "of", "strings"]+> zip_list_with_list_of_list [1 .. 9] ["a", "list", "of", "strings"]+-}+zip_list_with_list_of_list :: [p] -> [[q]] -> [[(p, q)]]+zip_list_with_list_of_list s l =+  case l of+    [] -> []+    e:l' ->+      let n = length e+      in zip (take n s) e : zip_list_with_list_of_list (drop n s) l'++-- | Fill gaps in a sorted association list, range is inclusive at both ends.+--+-- > let r = [(1,'a'),(2,'x'),(3,'x'),(4,'x'),(5,'b'),(6,'x'),(7,'c'),(8,'x'),(9,'x')]+-- > in fill_gaps_ascending' 'x' (1,9) (zip [1,5,7] "abc") == r+fill_gaps_ascending :: (Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]+fill_gaps_ascending def_e (l,r) =+    let f i (j,e) = if j > i then Left (i,def_e) else Right (j,e)+        g i = (i,def_e)+    in zip_with_perhaps_rhs f g [l .. r]++-- | Direct definition.+fill_gaps_ascending' :: (Num n,Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]+fill_gaps_ascending' def (l,r) =+    let recur n x =+            if n > r+            then []+            else case x of+                   [] -> zip [n .. r] (repeat def)+                   (m,e):x' -> if n < m+                               then (n,def) : recur (n + 1) x+                               else (m,e) : recur (n + 1) x'+    in recur l++-- | Variant with default value for empty input list case.+minimumBy_or :: t -> (t -> t -> Ordering) -> [t] -> t+minimumBy_or p f q = if null q then p else minimumBy f q++-- | 'minimum' and 'maximum' in one pass.+--+-- > minmax "minmax" == ('a','x')+minmax :: Ord t => [t] -> (t,t)+minmax inp =+    case inp of+      [] -> error "minmax: null"+      x:xs -> let mm p (l,r) = (min p l,max p r) in foldr mm (x,x) xs++-- | Append /k/ to the right of /l/ until result has /n/ places.+--   Truncates long input lists.+--+-- > map (pad_right '0' 2 . return) ['0' .. '9']+-- > pad_right '0' 12 "1101" == "110100000000"+-- > map (pad_right ' '3) ["S","E-L"] == ["S  ","E-L"]+-- > pad_right '!' 3 "truncate" == "tru"+pad_right :: a -> Int -> [a] -> [a]+pad_right k n l = take n (l ++ repeat k)++-- | Variant that errors if the input list has more than /n/ places.+--+-- > map (pad_right_err '!' 3) ["x","xy","xyz","xyz!"]+pad_right_err :: t -> Int -> [t] -> [t]+pad_right_err k n l = if length l > n then error "pad_right_err?" else pad_right k n l++-- | Variant that will not truncate long inputs.+--+-- > pad_right_no_truncate '!' 3 "truncate" == "truncate"+pad_right_no_truncate :: a -> Int -> [a] -> [a]+pad_right_no_truncate k n l = if length l > n then l else pad_right k n l++-- | Append /k/ to the left of /l/ until result has /n/ places.+--+-- > map (pad_left '0' 2 . return) ['0' .. '9']+pad_left :: a -> Int -> [a] -> [a]+pad_left k n l = replicate (n - length l) k ++ l++-- * Embedding++-- | Locate first (leftmost) embedding of /q/ in /p/.+-- Return partial indices for failure at 'Left'.+--+-- > embedding ("embedding","ming") == Right [1,6,7,8]+-- > embedding ("embedding","mind") == Left [1,6,7]+embedding :: Eq t => ([t],[t]) -> Either [Int] [Int]+embedding =+    let recur n r (p,q) =+            case (p,q) of+              (_,[]) -> Right (reverse r)+              ([],_) -> Left (reverse r)+              (x:p',y:q') ->+                  let n' = n + 1+                      r' = if x == y then n : r else r+                  in recur n' r' (p',if x == y then q' else q)+    in recur 0 []++-- | 'fromRight' of 'embedding'+embedding_err :: Eq t => ([t],[t]) -> [Int]+embedding_err = either (error "embedding_err") id . embedding++-- | Does /q/ occur in sequence, though not necessarily adjacently, in /p/.+--+-- > is_embedding [1 .. 9] [1,3,7] == True+-- > is_embedding "embedding" "ming" == True+-- > is_embedding "embedding" "mind" == False+is_embedding :: Eq t => [t] -> [t] -> Bool+is_embedding p q = T.is_right (embedding (p,q))++-- * Un-list++-- | Unpack one element list.+unlist1 :: [t] -> Maybe t+unlist1 l =+    case l of+      [e] -> Just e+      _ -> Nothing++-- | Erroring variant.+unlist1_err :: [t] -> t+unlist1_err = fromMaybe (error "unlist1") . unlist1++-- * Tree++{- | Given an 'Ordering' predicate where 'LT' opens a group, 'GT'+closes a group, and 'EQ' continues current group, construct tree+from list.++> let l = "a {b {c d} e f} g h i"+> let t = group_tree ((==) '{',(==) '}') l+> catMaybes (flatten t) == l++> let {d = putStrLn . drawTree . fmap show}+> in d (group_tree ((==) '(',(==) ')') "a(b(cd)ef)ghi")++-}+group_tree :: (a -> Bool,a -> Bool) -> [a] -> Tree.Tree (Maybe a)+group_tree (open_f,close_f) =+    let unit e = Tree.Node (Just e) []+        nil = Tree.Node Nothing []+        insert_e (Tree.Node t l) e = Tree.Node t (e:l)+        reverse_n (Tree.Node t l) = Tree.Node t (reverse l)+        do_push (r,z) e =+            case z of+              h:z' -> (r,insert_e h (unit e) : z')+              [] -> (unit e : r,[])+        do_open (r,z) = (r,nil:z)+        do_close (r,z) =+            case z of+              h0:h1:z' -> (r,insert_e h1 (reverse_n h0) : z')+              h:z' -> (reverse_n h : r,z')+              [] -> (r,z)+        go st x =+            case x of+              [] -> Tree.Node Nothing (reverse (fst st))+              e:x' -> if open_f e+                      then go (do_push (do_open st) e) x'+                      else if close_f e+                           then go (do_close (do_push st e)) x'+                           else go (do_push st e) x'+    in go ([],[])++-- * Indexing++{- | Remove element at index.++> map (remove_ix 5) ["remove","removed"] == ["remov","removd"]+> remove_ix 5 "short" -- error+-}+remove_ix :: Int -> [a] -> [a]+remove_ix k l = let (p,q) = splitAt k l in p ++ tail q++{- | Delete element at ix from list (c.f. remove_ix, this has a more specific error if index does not exist).++> delete_at 3 "deleted" == "delted"+> delete_at 8 "deleted" -- error+-}+delete_at :: (Eq t, Num t) => t -> [a] -> [a]+delete_at ix l =+  case (ix,l) of+    (_,[]) -> error "delete_at: index does not exist"+    (0,_:l') -> l'+    (_,e:l') -> e : delete_at (ix - 1) l'++-- | Select or remove elements at set of indices.+operate_ixs :: Bool -> [Int] -> [a] -> [a]+operate_ixs mode k =+    let sel = if mode then notElem else elem+        f (n,e) = if n `sel` k then Nothing else Just e+    in mapMaybe f . zip [0..]++-- | Select elements at set of indices.+--+-- > select_ixs [1,3] "select" == "ee"+select_ixs :: [Int] -> [a] -> [a]+select_ixs = operate_ixs True++-- | Remove elements at set of indices.+--+-- > remove_ixs [1,3,5] "remove" == "rmv"+remove_ixs :: [Int] -> [a] -> [a]+remove_ixs = operate_ixs False++-- | Replace element at /i/ in /p/ by application of /f/.+--+-- > replace_ix negate 1 [1..3] == [1,-2,3]+replace_ix :: (a -> a) -> Int -> [a] -> [a]+replace_ix f i p =+    let (q,r) = splitAt i p+        (s,t) = headTail r+    in q ++ (f s : t)++-- | List equality, ignoring indicated indices.+--+-- > list_eq_ignoring_indices [3,5] "abcdefg" "abc.e.g" == True+list_eq_ignoring_indices :: (Eq t,Integral i) => [i] -> [t] -> [t] -> Bool+list_eq_ignoring_indices x =+  let f n p q =+        case (p,q) of+          ([],[]) -> True+          ([],_) -> False+          (_,[]) -> False+          (p1:p',q1:q') -> (n `elem` x || p1 == q1) &&+                           f (n + 1) p' q'+  in f 0++-- | Edit list to have /v/ at indices /k/.+--   Replacement assoc-list must be ascending.+--   All replacements must be in range.+--+-- > list_set_indices [(2,'C'),(4,'E')] "abcdefg" == "abCdEfg"+-- > list_set_indices [] "abcdefg" == "abcdefg"+-- > list_set_indices [(9,'I')] "abcdefg" == undefined+list_set_indices :: (Eq ix, Num ix) => [(ix,t)] -> [t] -> [t]+list_set_indices =+  let f n r l =+        case (r,l) of+          ([],_) -> l+          (_,[]) -> error "list_set_indices: out of range?"+          ((k,v):r',l0:l') -> if n == k+                              then v : f (n + 1) r' l'+                              else l0 : f (n + 1) r l'+  in f 0++-- | Variant of 'list_set_indices' with one replacement.+list_set_ix :: (Eq t, Num t) => t -> a -> [a] -> [a]+list_set_ix k v = list_set_indices [(k,v)]++-- | Cyclic indexing function.+--+-- > map (at_cyclic "cycle") [0..9] == "cyclecycle"+at_cyclic :: [a] -> Int -> a+at_cyclic l n =+    let m = Map.fromList (zip [0..] l)+        k = Map.size m+        n' = n `mod` k+    in fromMaybe (error "cyc_at") (Map.lookup n' m)++{- | Index list from the end, assuming the list is longer than n + 1.++atFromEnd [1 .. 30] 0 == 30+atFromEnd [1..100] 15 == 85+-}+atFromEnd :: [t] -> Int -> t+atFromEnd lst n =+  let loop xs ys = last (zipWith const xs ys)+  in loop lst (drop n lst)+

@@ -0,0 +1,17 @@+-- | Map functions.+module Music.Theory.Map where++import qualified Data.Map as M {- containers -}+import Data.Maybe {- base -}++-- | Erroring 'M.lookup'.+map_lookup_err :: Ord k => k -> M.Map k c -> c+map_lookup_err k = fromMaybe (error "M.lookup") . M.lookup k++-- | 'flip' of 'M.lookup'.+map_ix :: Ord k => M.Map k c -> k -> Maybe c+map_ix = flip M.lookup++-- | 'flip' of 'map_lookup_err'.+map_ix_err :: Ord k => M.Map k c -> k -> c+map_ix_err = flip map_lookup_err

@@ -0,0 +1,290 @@+-- | Math functions.+module Music.Theory.Math where++import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -}++import qualified Music.Theory.Math.Convert as T {- hmt-base -}++-- | 'mod' 5.+mod5 :: Integral i => i -> i+mod5 n = n `mod` 5++-- | 'mod' 7.+mod7 :: Integral i => i -> i+mod7 n = n `mod` 7++-- | 'mod' 12.+mod12 :: Integral i => i -> i+mod12 n = n `mod` 12++-- | 'mod' 16.+mod16 :: Integral i => i -> i+mod16 n = n `mod` 16++-- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html>+--   i.e. 'properFraction'+--+-- > integral_and_fractional_parts 1.5 == (1,0.5)+integral_and_fractional_parts :: (Integral i, RealFrac t) => t -> (i,t)+integral_and_fractional_parts = properFraction++-- | Type specialised.+integer_and_fractional_parts :: RealFrac t => t -> (Integer,t)+integer_and_fractional_parts = integral_and_fractional_parts++-- | <http://reference.wolfram.com/mathematica/ref/FractionalPart.html>+--+-- > import Sound.SC3.Plot {- hsc3-plot -}+-- > plot_p1_ln [map fractional_part [-2.0,-1.99 .. 2.0]]+fractional_part :: RealFrac a => a -> a+fractional_part = snd . integer_and_fractional_parts++-- | 'floor' of 'T.real_to_double'.+real_floor :: (Real r,Integral i)  => r -> i+real_floor = floor . T.real_to_double++-- | Type specialised 'real_floor'.+real_floor_int :: Real r => r -> Int+real_floor_int = real_floor++-- | 'round' of 'T.real_to_double'.+real_round :: (Real r,Integral i)  => r -> i+real_round = round . T.real_to_double++-- | Type specialised 'real_round'.+real_round_int :: Real r => r -> Int+real_round_int = real_round++-- | Type specialised 'round'+round_int :: RealFrac t => t -> Int+round_int = round++-- | Type-specialised 'fromIntegral'+from_integral_to_int :: Integral i => i -> Int+from_integral_to_int = fromIntegral++-- | Type-specialised 'id'+int_id :: Int -> Int+int_id = id++-- | Is /r/ zero to /k/ decimal places.+--+-- > map (flip zero_to_precision 0.00009) [4,5] == [True,False]+-- > map (zero_to_precision 4) [0.00009,1.00009] == [True,False]+zero_to_precision :: Real r => Int -> r -> Bool+zero_to_precision k r = real_floor_int (r * fromIntegral ((10::Int) ^ k)) == 0++-- | Is /r/ whole to /k/ decimal places.+--+-- > map (flip whole_to_precision 1.00009) [4,5] == [True,False]+whole_to_precision :: Real r => Int -> r -> Bool+whole_to_precision k = zero_to_precision k . fractional_part . T.real_to_double++-- | <http://reference.wolfram.com/mathematica/ref/SawtoothWave.html>+--+-- > plot_p1_ln [map sawtooth_wave [-2.0,-1.99 .. 2.0]]+sawtooth_wave :: RealFrac a => a -> a+sawtooth_wave n = n - floor_f n++-- | Predicate that is true if @n/d@ can be simplified, ie. where+-- 'gcd' of @n@ and @d@ is not @1@.+--+-- > map rational_simplifies [(2,3),(4,6),(5,7)] == [False,True,False]+rational_simplifies :: Integral a => (a,a) -> Bool+rational_simplifies (n,d) = gcd n d /= 1++-- | 'numerator' and 'denominator' of rational.+rational_nd :: 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++-- | Sum of numerator & denominator.+ratio_nd_sum :: Integral t => Ratio t -> t+ratio_nd_sum r = numerator r + denominator r++-- | Is /n/ a whole (integral) value.+--+-- > map real_is_whole [-1.0,-0.5,0.0,0.5,1.0] == [True,False,True,False,True]+real_is_whole :: Real n => n -> Bool+real_is_whole = (== 1) . denominator . toRational++-- | 'fromInteger' . 'floor'.+floor_f :: (RealFrac a, Num b) => a -> b+floor_f = fromInteger . floor++-- | Round /b/ to nearest multiple of /a/.+--+-- > map (round_to 0.25) [0,0.1 .. 1] == [0.0,0.0,0.25,0.25,0.5,0.5,0.5,0.75,0.75,1.0,1.0]+-- > map (round_to 25) [0,10 .. 100] == [0,0,25,25,50,50,50,75,75,100,100]+round_to :: RealFrac n => n -> n -> n+round_to a b = if a == 0 then b else floor_f ((b / a) + 0.5) * a++-- | Variant of 'recip' that checks input for zero.+--+-- > map recip [1,1/2,0,-1]+-- > map recip_m [1,1/2,0,-1] == [Just 1,Just 2,Nothing,Just (-1)]+recip_m :: (Eq a, Fractional a) => a -> Maybe a+recip_m x = if x == 0 then Nothing else Just (recip x)++-- * One-indexed++-- | One-indexed 'mod' function.+--+-- > map (`oi_mod` 5) [1..10] == [1,2,3,4,5,1,2,3,4,5]+oi_mod :: Integral a => a -> a -> a+oi_mod n m = ((n - 1) `mod` m) + 1++-- | One-indexed 'divMod' function.+--+-- > map (`oi_divMod` 5) [1,3 .. 9] == [(0,1),(0,3),(0,5),(1,2),(1,4)]+oi_divMod :: Integral t => t -> t -> (t, t)+oi_divMod n m = let (i,j) = (n - 1) `divMod` m in (i,j + 1)++-- * I = integral++-- | Integral square root (sqrt) function.+--+-- > map i_square_root [0,1,4,9,16,25,36,49,64,81,100] == [0 .. 10]+-- > map i_square_root [4 .. 16] == [2,2,2,2,2,3,3,3,3,3,3,3,4]+i_square_root :: Integral t => t -> t+i_square_root n =+    let babylon a =+            let b  = quot (a + quot n a) 2+            in if a > b then babylon b else a+    in case compare n 0 of+         GT -> babylon n+         EQ -> 0+         _ -> error "i_square_root: negative?"++-- * Interval++-- | (0,1) = {x | 0 < x < 1}+in_open_interval :: Ord a => (a, a) -> a -> Bool+in_open_interval (p,q) n = p < n && n < q++-- | [0,1] = {x | 0 ≤ x ≤ 1}+in_closed_interval :: Ord a => (a, a) -> a -> Bool+in_closed_interval (p,q) n = p <= n && n <= q++-- | (p,q] (0,1] = {x | 0 < x ≤ 1}+in_left_half_open_interval :: Ord a => (a, a) -> a -> Bool+in_left_half_open_interval (p,q) n = p < n && n <= q++-- | [p,q) [0,1) = {x | 0 ≤ x < 1}+in_right_half_open_interval :: Ord a => (a, a) -> a -> Bool+in_right_half_open_interval (p,q) n = p <= n && n < q++-- | Calculate /n/th root of /x/.+--+-- > 12 `nth_root` 2 == 1.0594630943592953+nth_root :: (Floating a,Eq a) => a -> a -> a+nth_root n x =+    let f (_,x0) = (x0, ((n - 1) * x0 + x / x0 ** (n - 1)) / n)+        eq = uncurry (==)+    in fst (until eq f (x, x/n))++-- | Arithmetic mean (average) of a list.+--+-- > map arithmetic_mean [[-3..3],[0..5],[1..5],[3,5,7],[7,7],[3,9,10,11,12]] == [0,2.5,3,5,7,9]+arithmetic_mean :: Fractional a => [a] -> a+arithmetic_mean x = sum x / fromIntegral (length x)++-- | Numerically stable mean+--+-- > map ns_mean [[-3..3],[0..5],[1..5],[3,5,7],[7,7],[3,9,10,11,12]] == [0,2.5,3,5,7,9]+ns_mean :: Floating a => [a] -> a+ns_mean =+    let f (m,n) x = (m + (x - m) / (n + 1),n + 1)+    in fst . foldl' f (0,0)++-- | Square of /n/.+--+-- > square 5 == 25+square :: Num a => a -> a+square n = n * n++-- | The totient function phi(n), also called Euler's totient function.+--+-- > import Sound.SC3.Plot {- hsc3-plot -}+-- > plot_p1_stp [map totient [1::Int .. 100]]+totient :: Integral i => i -> i+totient n = genericLength (filter (==1) (map (gcd n) [1..n]))++{- | The /n/-th order Farey sequence.++> farey 1 == [0,                                                                                    1]+> farey 2 == [0,                                        1/2,                                        1]+> farey 3 == [0,                        1/3,            1/2,            2/3,                        1]+> farey 4 == [0,                1/4,    1/3,            1/2,            2/3,    3/4,                1]+> farey 5 == [0,            1/5,1/4,    1/3,    2/5,    1/2,    3/5,    2/3,    3/4,4/5,            1]+> farey 6 == [0,        1/6,1/5,1/4,    1/3,    2/5,    1/2,    3/5,    2/3,    3/4,4/5,5/6,        1]+> farey 7 == [0,    1/7,1/6,1/5,1/4,2/7,1/3,    2/5,3/7,1/2,4/7,3/5,    2/3,5/7,3/4,4/5,5/6,6/7,    1]+> farey 8 == [0,1/8,1/7,1/6,1/5,1/4,2/7,1/3,3/8,2/5,3/7,1/2,4/7,3/5,5/8,2/3,5/7,3/4,4/5,5/6,6/7,7/8,1]+-}+farey :: Integral i => i -> [Ratio i]+farey n =+  let step (a,b,c,d) =+        if c > n+        then Nothing+        else let k = (n + b) `quot` d in Just (c % d, (c,d,k * c - a,k * d - b))+  in 0 : unfoldr step (0,1,1,n)++-- | The length of the /n/-th order Farey sequence.+--+-- > map farey_length [1 .. 12] == [2,3,5,7,11,13,19,23,29,33,43,47]+-- > map (length . farey) [1 .. 12] == map farey_length [1 .. 12]+farey_length :: Integral i => i -> i+farey_length n = if n == 0 then 1 else farey_length (n - 1) + totient n++-- | Function to generate the Stern-Brocot tree from an initial row.+--   '%' normalises so 1/0 cannot be written as a 'Rational', hence (n,d).+stern_brocot_tree_f :: Num n => [(n,n)] -> [[(n,n)]]+stern_brocot_tree_f =+   let med_f (n1,d1) (n2,d2) = (n1 + n2,d1 + d2)+       f x = concat (transpose [x, zipWith med_f x (tail x)])+   in iterate f++{- | The Stern-Brocot tree from (0/1,1/0).++> let t = stern_brocot_tree+> t !! 0 == [(0,1),(1,0)]+> t !! 1 == [(0,1),(1,1),(1,0)]+> t !! 2 == [(0,1),(1,2),(1,1),(2,1),(1,0)]+> t !! 3 == [(0,1),(1,3),(1,2),(2,3),(1,1),(3,2),(2,1),(3,1),(1,0)]++> map length (take 12 stern_brocot_tree) == [2,3,5,9,17,33,65,129,257,513,1025,2049] -- A000051+-}+stern_brocot_tree :: Num n => [[(n,n)]]+stern_brocot_tree = stern_brocot_tree_f [(0,1),(1,0)]++-- | Left-hand (rational) side of the the Stern-Brocot tree, ie, from (0/1,1/1).+stern_brocot_tree_lhs :: Num n => [[(n,n)]]+stern_brocot_tree_lhs = stern_brocot_tree_f [(0,1),(1,1)]++{- | 'stern_brocot_tree_f' as 'Ratio's, for finite subsets.++> let t = stern_brocot_tree_f_r [0,1]+> t !! 1 == [0,1/2,1]+> t !! 2 == [0,1/3,1/2,2/3,1]+> t !! 3 == [0,1/4,1/3,2/5,1/2,3/5,2/3,3/4,1]+> t !! 4 == [0,1/5,1/4,2/7,1/3,3/8,2/5,3/7,1/2,4/7,3/5,5/8,2/3,5/7,3/4,4/5,1]+-}+stern_brocot_tree_f_r :: Integral n => [Ratio n] -> [[Ratio n]]+stern_brocot_tree_f_r = map (map (uncurry (%))) . stern_brocot_tree_f . map rational_nd++{- | Outer product of vectors represented as lists, c.f. liftM2++> outer_product (*) [2..5] [2..5] == [[4,6,8,10],[6,9,12,15],[8,12,16,20],[10,15,20,25]]+> liftM2 (*) [2..5] [2..5] == [4,6,8,10,6,9,12,15,8,12,16,20,10,15,20,25]+-}+outer_product :: (a -> b -> c) -> [a] -> [b] -> [[c]]+outer_product f xs ys = map (flip map ys . f) xs

@@ -0,0 +1,16 @@+-- | IEE754 constants (c.f. Numeric.MathFunctions.Constants)+module Music.Theory.Math.Constant where++-- | The smallest 'Double' n such that 1 + n /= 1.+epsilonValue :: Double+epsilonValue =+  let (signif, expo) = decodeFloat (1.0 :: Double)+  in encodeFloat (signif + 1) expo - 1.0++-- | Largest representable finite value.+largestFiniteValue :: Double+largestFiniteValue = 1.7976931348623157e308++-- | The smallest representable positive normalized value.+smallestNormalizedValue :: Double+smallestNormalizedValue = 2.2250738585072014e-308

@@ -0,0 +1,1147 @@+{- | Specialised type conversions, see mk/mk-convert.hs++> map int_to_word8 [-1,0,255,256] == [255,0,255,0]+> map int_to_word8_maybe [-1,0,255,256] == [Nothing,Just 0,Just 255,Nothing]++> map integer_to_int64_maybe [-2 ^ 63 - 1,2 ^ 63] == [Nothing,Nothing]+> map integer_to_word64_maybe [2 ^ 64 - 1,2 ^ 64] == [Just 18446744073709551615,Nothing]++> map int16_to_float [-1,0,1] == [-1,0,1]++-}+module Music.Theory.Math.Convert where++import Data.Int {- base -}+import Data.Word {- base -}++-- * Numerical conversions++-- | Type specialised 'realToFrac'+real_to_float :: Real t => t -> Float+real_to_float = realToFrac++-- | Type specialised 'realToFrac'+--+-- > let n = sqrt (-1) in (n,real_to_double n)+real_to_double :: Real t => t -> Double+real_to_double = realToFrac++-- | Type specialised 'realToFrac'+double_to_float :: Double -> Float+double_to_float = realToFrac++-- | Type specialised 'realToFrac'+float_to_double :: Float -> Double+float_to_double = realToFrac++double_to_word8 :: (Double -> Word8) -> Double -> Word8+double_to_word8 = id++{- | Type-specialise /f/, ie. round, ceiling, truncate++> map (double_to_int round) [0, 0.25 .. 1] == [0, 0, 0, 1, 1]+> map (double_to_int ceiling) [0, 0.25 .. 1] == [0, 1, 1, 1, 1]+> map (double_to_int floor) [0, 0.25 .. 1] == [0, 0, 0, 0, 1]+> map (double_to_int truncate) [0, 0.25 .. 1] == [0, 0, 0, 0, 1]+-}+double_to_int :: (Double -> Int) -> Double -> Int+double_to_int = id++-- | Type specialised 'fromIntegral'+int_to_rational :: Int -> Rational+int_to_rational = fromIntegral++-- AUTOGEN (see mk/mk-convert.hs)++-- | Type specialised 'fromIntegral'+word8_to_word16 :: Word8 -> Word16+word8_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_word32 :: Word8 -> Word32+word8_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_word64 :: Word8 -> Word64+word8_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_int8 :: Word8 -> Int8+word8_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_int16 :: Word8 -> Int16+word8_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_int32 :: Word8 -> Int32+word8_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_int64 :: Word8 -> Int64+word8_to_int64 = fromIntegral+++-- | Type specialised 'fromIntegral'+word8_to_int :: Word8 -> Int+word8_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_integer :: Word8 -> Integer+word8_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_float :: Word8 -> Float+word8_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_double :: Word8 -> Double+word8_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_word8 :: Word16 -> Word8+word16_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_word32 :: Word16 -> Word32+word16_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_word64 :: Word16 -> Word64+word16_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_int8 :: Word16 -> Int8+word16_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_int16 :: Word16 -> Int16+word16_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_int32 :: Word16 -> Int32+word16_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_int64 :: Word16 -> Int64+word16_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_int :: Word16 -> Int+word16_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_integer :: Word16 -> Integer+word16_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_float :: Word16 -> Float+word16_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_double :: Word16 -> Double+word16_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_word8 :: Word32 -> Word8+word32_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_word16 :: Word32 -> Word16+word32_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_word64 :: Word32 -> Word64+word32_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int8 :: Word32 -> Int8+word32_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int16 :: Word32 -> Int16+word32_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int32 :: Word32 -> Int32+word32_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int64 :: Word32 -> Int64+word32_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int :: Word32 -> Int+word32_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_integer :: Word32 -> Integer+word32_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_float :: Word32 -> Float+word32_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_double :: Word32 -> Double+word32_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_word8 :: Word64 -> Word8+word64_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_word16 :: Word64 -> Word16+word64_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_word32 :: Word64 -> Word32+word64_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_int8 :: Word64 -> Int8+word64_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_int16 :: Word64 -> Int16+word64_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_int32 :: Word64 -> Int32+word64_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_int64 :: Word64 -> Int64+word64_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_int :: Word64 -> Int+word64_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_integer :: Word64 -> Integer+word64_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_float :: Word64 -> Float+word64_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_double :: Word64 -> Double+word64_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_word8 :: Int8 -> Word8+int8_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_word16 :: Int8 -> Word16+int8_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_word32 :: Int8 -> Word32+int8_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_word64 :: Int8 -> Word64+int8_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_int16 :: Int8 -> Int16+int8_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_int32 :: Int8 -> Int32+int8_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_int64 :: Int8 -> Int64+int8_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_int :: Int8 -> Int+int8_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_integer :: Int8 -> Integer+int8_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_float :: Int8 -> Float+int8_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+int8_to_double :: Int8 -> Double+int8_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_word8 :: Int16 -> Word8+int16_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_word16 :: Int16 -> Word16+int16_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_word32 :: Int16 -> Word32+int16_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_word64 :: Int16 -> Word64+int16_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_int8 :: Int16 -> Int8+int16_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_int32 :: Int16 -> Int32+int16_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_int64 :: Int16 -> Int64+int16_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_int :: Int16 -> Int+int16_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_integer :: Int16 -> Integer+int16_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_float :: Int16 -> Float+int16_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_double :: Int16 -> Double+int16_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_word8 :: Int32 -> Word8+int32_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_word16 :: Int32 -> Word16+int32_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_word32 :: Int32 -> Word32+int32_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_word64 :: Int32 -> Word64+int32_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_int8 :: Int32 -> Int8+int32_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_int16 :: Int32 -> Int16+int32_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_int64 :: Int32 -> Int64+int32_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_int :: Int32 -> Int+int32_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_integer :: Int32 -> Integer+int32_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_float :: Int32 -> Float+int32_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_double :: Int32 -> Double+int32_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_word8 :: Int64 -> Word8+int64_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_word16 :: Int64 -> Word16+int64_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_word32 :: Int64 -> Word32+int64_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_word64 :: Int64 -> Word64+int64_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_int8 :: Int64 -> Int8+int64_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_int16 :: Int64 -> Int16+int64_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_int32 :: Int64 -> Int32+int64_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_int :: Int64 -> Int+int64_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_integer :: Int64 -> Integer+int64_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_float :: Int64 -> Float+int64_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_double :: Int64 -> Double+int64_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_integral :: Integral i => Int -> i+int_to_integral = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_word8 :: Int -> Word8+int_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_word16 :: Int -> Word16+int_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_word32 :: Int -> Word32+int_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_word64 :: Int -> Word64+int_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int8 :: Int -> Int8+int_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int16 :: Int -> Int16+int_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int32 :: Int -> Int32+int_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int64 :: Int -> Int64+int_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_integer :: Int -> Integer+int_to_integer = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_float :: Int -> Float+int_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_double :: Int -> Double+int_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_word8 :: Integer -> Word8+integer_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_word16 :: Integer -> Word16+integer_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_word32 :: Integer -> Word32+integer_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_word64 :: Integer -> Word64+integer_to_word64 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_int8 :: Integer -> Int8+integer_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_int16 :: Integer -> Int16+integer_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_int32 :: Integer -> Int32+integer_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_int64 :: Integer -> Int64+integer_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_int :: Integer -> Int+integer_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_float :: Integer -> Float+integer_to_float = fromIntegral++-- | Type specialised 'fromIntegral'+integer_to_double :: Integer -> Double+integer_to_double = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_word16_maybe :: Word8 -> Maybe Word16+word8_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word8_to_word32_maybe :: Word8 -> Maybe Word32+word8_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word8_to_word64_maybe :: Word8 -> Maybe Word64+word8_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word8_to_int8_maybe :: Word8 -> Maybe Int8+word8_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word8_to_int16_maybe :: Word8 -> Maybe Int16+word8_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word8_to_int32_maybe :: Word8 -> Maybe Int32+word8_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word8_to_int64_maybe :: Word8 -> Maybe Int64+word8_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word8_to_int_maybe :: Word8 -> Maybe Int+word8_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_word8_maybe :: Word16 -> Maybe Word8+word16_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_word32_maybe :: Word16 -> Maybe Word32+word16_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_word64_maybe :: Word16 -> Maybe Word64+word16_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_int8_maybe :: Word16 -> Maybe Int8+word16_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_int16_maybe :: Word16 -> Maybe Int16+word16_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_int32_maybe :: Word16 -> Maybe Int32+word16_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_int64_maybe :: Word16 -> Maybe Int64+word16_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word16_to_int_maybe :: Word16 -> Maybe Int+word16_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_word8_maybe :: Word32 -> Maybe Word8+word32_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_word16_maybe :: Word32 -> Maybe Word16+word32_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_word64_maybe :: Word32 -> Maybe Word64+word32_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_int8_maybe :: Word32 -> Maybe Int8+word32_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_int16_maybe :: Word32 -> Maybe Int16+word32_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_int32_maybe :: Word32 -> Maybe Int32+word32_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_int64_maybe :: Word32 -> Maybe Int64+word32_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word32_to_int_maybe :: Word32 -> Maybe Int+word32_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_word8_maybe :: Word64 -> Maybe Word8+word64_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_word16_maybe :: Word64 -> Maybe Word16+word64_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_word32_maybe :: Word64 -> Maybe Word32+word64_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_int8_maybe :: Word64 -> Maybe Int8+word64_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_int16_maybe :: Word64 -> Maybe Int16+word64_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_int32_maybe :: Word64 -> Maybe Int32+word64_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_int64_maybe :: Word64 -> Maybe Int64+word64_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+word64_to_int_maybe :: Word64 -> Maybe Int+word64_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_word8_maybe :: Int8 -> Maybe Word8+int8_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_word16_maybe :: Int8 -> Maybe Word16+int8_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_word32_maybe :: Int8 -> Maybe Word32+int8_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_word64_maybe :: Int8 -> Maybe Word64+int8_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_int16_maybe :: Int8 -> Maybe Int16+int8_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_int32_maybe :: Int8 -> Maybe Int32+int8_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_int64_maybe :: Int8 -> Maybe Int64+int8_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int8_to_int_maybe :: Int8 -> Maybe Int+int8_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_word8_maybe :: Int16 -> Maybe Word8+int16_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_word16_maybe :: Int16 -> Maybe Word16+int16_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_word32_maybe :: Int16 -> Maybe Word32+int16_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_word64_maybe :: Int16 -> Maybe Word64+int16_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_int8_maybe :: Int16 -> Maybe Int8+int16_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_int32_maybe :: Int16 -> Maybe Int32+int16_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_int64_maybe :: Int16 -> Maybe Int64+int16_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int16_to_int_maybe :: Int16 -> Maybe Int+int16_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_word8_maybe :: Int32 -> Maybe Word8+int32_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_word16_maybe :: Int32 -> Maybe Word16+int32_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_word32_maybe :: Int32 -> Maybe Word32+int32_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_word64_maybe :: Int32 -> Maybe Word64+int32_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_int8_maybe :: Int32 -> Maybe Int8+int32_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_int16_maybe :: Int32 -> Maybe Int16+int32_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_int64_maybe :: Int32 -> Maybe Int64+int32_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int32_to_int_maybe :: Int32 -> Maybe Int+int32_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_word8_maybe :: Int64 -> Maybe Word8+int64_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_word16_maybe :: Int64 -> Maybe Word16+int64_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_word32_maybe :: Int64 -> Maybe Word32+int64_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_word64_maybe :: Int64 -> Maybe Word64+int64_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_int8_maybe :: Int64 -> Maybe Int8+int64_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_int16_maybe :: Int64 -> Maybe Int16+int64_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_int32_maybe :: Int64 -> Maybe Int32+int64_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int64_to_int_maybe :: Int64 -> Maybe Int+int64_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_word8_maybe :: Int -> Maybe Word8+int_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_word16_maybe :: Int -> Maybe Word16+int_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_word32_maybe :: Int -> Maybe Word32+int_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_word64_maybe :: Int -> Maybe Word64+int_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_int8_maybe :: Int -> Maybe Int8+int_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_int16_maybe :: Int -> Maybe Int16+int_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_int32_maybe :: Int -> Maybe Int32+int_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+int_to_int64_maybe :: Int -> Maybe Int64+int_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_word8_maybe :: Integer -> Maybe Word8+integer_to_word8_maybe n =+    if n < fromIntegral (minBound::Word8) ||+       n > fromIntegral (maxBound::Word8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_word16_maybe :: Integer -> Maybe Word16+integer_to_word16_maybe n =+    if n < fromIntegral (minBound::Word16) ||+       n > fromIntegral (maxBound::Word16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_word32_maybe :: Integer -> Maybe Word32+integer_to_word32_maybe n =+    if n < fromIntegral (minBound::Word32) ||+       n > fromIntegral (maxBound::Word32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_word64_maybe :: Integer -> Maybe Word64+integer_to_word64_maybe n =+    if n < fromIntegral (minBound::Word64) ||+       n > fromIntegral (maxBound::Word64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_int8_maybe :: Integer -> Maybe Int8+integer_to_int8_maybe n =+    if n < fromIntegral (minBound::Int8) ||+       n > fromIntegral (maxBound::Int8)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_int16_maybe :: Integer -> Maybe Int16+integer_to_int16_maybe n =+    if n < fromIntegral (minBound::Int16) ||+       n > fromIntegral (maxBound::Int16)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_int32_maybe :: Integer -> Maybe Int32+integer_to_int32_maybe n =+    if n < fromIntegral (minBound::Int32) ||+       n > fromIntegral (maxBound::Int32)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_int64_maybe :: Integer -> Maybe Int64+integer_to_int64_maybe n =+    if n < fromIntegral (minBound::Int64) ||+       n > fromIntegral (maxBound::Int64)+    then Nothing+    else Just (fromIntegral n)++-- | Type specialised 'fromIntegral'+integer_to_int_maybe :: Integer -> Maybe Int+integer_to_int_maybe n =+    if n < fromIntegral (minBound::Int) ||+       n > fromIntegral (maxBound::Int)+    then Nothing+    else Just (fromIntegral n)

@@ -0,0 +1,38 @@+-- | c.f. Statistics.Sample.Histogram (this is much slower but doesn't require any libraries)+module Music.Theory.Math.Histogram where++import Music.Theory.List {- hmt-base -}+import Music.Theory.Math.Constant {- hmt-base -}++{- | Calculate histogram on numBins places.  Returns the range of each bin and the number of elements in each.+++> map (snd . bHistogram 10) [[1 .. 10],[1,1,1,2,2,3,10]] == [[1,1,1,1,1,1,1,1,1,1],[3,2,1,0,0,0,0,0,0,1]]+-}+bHistogram :: Int -> [Double] -> ([(Double, Double)], [Int])+bHistogram numBins xs =+  let (lo, hi) = bHistogramRange numBins xs+      d = (hi - lo) / fromIntegral numBins+      step i = lo + d * fromIntegral i+      lhs_seq = map step [0 .. numBins - 1]+      rng_seq = map (\n -> (n, n + d)) lhs_seq+      cnt_seq = map (\rng -> length (filterInRange rng xs)) rng_seq+  in (rng_seq, cnt_seq)++{- | Calculate range.++> bHistogramRange 10 (replicate 10 1) == (0.9, 1.1)+> bHistogramRange 10 (replicate 10 0) == (-1, 1)+> bHistogramRange 10 [1 .. 10] == (0.5, 10.5)+> bHistogramRange 25 [1 .. 10] == (0.8125,10.1875)+-}+bHistogramRange :: Int -> [Double] -> (Double, Double)+bHistogramRange numBins xs =+  let d = if numBins == 1 then 0 else (hi - lo) / ((fromIntegral numBins - 1) * 2)+      (lo, hi) = minmax xs+  in if numBins < 1 || null xs+     then error "bHistogramRange: empty sample"+     else if lo == hi+          then let a = abs lo / 10+               in if a < smallestNormalizedValue then (-1,1) else (lo - a, lo + a)+          else (lo-d, hi+d)

@@ -0,0 +1,91 @@+-- | Extensions to "Data.Maybe".+module Music.Theory.Maybe where++import Data.Maybe {- base -}++-- | Variant with error text.+from_just :: String -> Maybe a -> a+from_just err = fromMaybe (error err)++-- | Variant of unzip.+--+-- > let r = ([Just 1,Nothing,Just 3],[Just 'a',Nothing,Just 'c'])+-- > in maybe_unzip [Just (1,'a'),Nothing,Just (3,'c')] == r+maybe_unzip :: [Maybe (a,b)] -> ([Maybe a],[Maybe b])+maybe_unzip =+    let f x = case x of+                Nothing -> (Nothing,Nothing)+                Just (i,j) -> (Just i,Just j)+    in unzip . map f++-- | Replace 'Nothing' elements with last 'Just' value.  This does not+-- alter the length of the list.+--+-- > maybe_latch 1 [Nothing,Just 2,Nothing,Just 4] == [1,2,2,4]+maybe_latch :: a -> [Maybe a] -> [a]+maybe_latch i x =+    case x of+      [] -> []+      Just e:x' -> e : maybe_latch e x'+      Nothing:x' -> i : maybe_latch i x'++-- | Variant requiring initial value is not 'Nothing'.+--+-- > maybe_latch1 [Just 1,Nothing,Nothing,Just 4] == [1,1,1,4]+maybe_latch1 :: [Maybe a] -> [a]+maybe_latch1 = maybe_latch (error "maybe_latch1")++-- | 'map' of 'fmap'.+--+-- > maybe_map negate [Nothing,Just 2] == [Nothing,Just (-2)]+maybe_map :: (a -> b) -> [Maybe a] -> [Maybe b]+maybe_map = map . fmap++-- | If either is 'Nothing' then 'False', else /eq/ of values.+maybe_eq_by :: (t -> u -> Bool) -> Maybe t -> Maybe u -> Bool+maybe_eq_by eq_fn p q =+    case (p,q) of+      (Just p',Just q') -> eq_fn p' q'+      _ -> False++-- | Join two values, either of which may be missing.+maybe_join' :: (s -> t) -> (s -> s -> t) -> Maybe s -> Maybe s -> Maybe t+maybe_join' f g p q =+    case (p,q) of+      (Nothing,_) -> fmap f q+      (_,Nothing) -> fmap f p+      (Just p',Just q') -> Just (p' `g` q')++-- | 'maybe_join'' of 'id'+maybe_join :: (t -> t -> t) -> Maybe t -> Maybe t -> Maybe t+maybe_join = maybe_join' id++-- | Apply predicate inside 'Maybe'.+--+-- > maybe_predicate even (Just 3) == Nothing+maybe_predicate :: (a -> Bool) -> Maybe a -> Maybe a+maybe_predicate f i =+    case i of+      Nothing -> Nothing+      Just j -> if f j then Just j else Nothing++-- | 'map' of 'maybe_predicate'.+--+-- > let r = [Nothing,Nothing,Nothing,Just 4]+-- > in maybe_filter even [Just 1,Nothing,Nothing,Just 4] == r+maybe_filter :: (a -> Bool) -> [Maybe a] -> [Maybe a]+maybe_filter = map . maybe_predicate++{- | 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+

@@ -0,0 +1,22 @@+-- | Monad functions.+module Music.Theory.Monad where++-- | 'sequence_' of 'repeat'.+repeatM_ :: Monad m => m a -> m ()+repeatM_ = sequence_ . repeat++-- | Monadic variant of 'iterate'.+iterateM_ :: Monad m => (st -> m st) -> st -> m ()+iterateM_ f st = do+  st' <- f st+  iterateM_ f st'++-- | 'fmap' of 'concat' of 'mapM'+concatMapM :: (Functor m, Monad m) => (t -> m [u]) -> [t] -> m [u]+concatMapM f = fmap concat . mapM f++-- | If i then j else k.+m_if :: Monad m => (m Bool,m t,m t) -> m t+m_if (i,j,k) = do+  r <- i+  if r then j else k

@@ -0,0 +1,156 @@+{- | Very simple command line interface option parser.++Only allows options of the form --key=value, with the form --key equal to --key=True.++A list of OptUsr describes the options and provides default values.++'get_opt_arg' merges user and default values into a table with values for all options.++To fetch options use 'opt_get' and 'opt_read'.++-}+module Music.Theory.Opt where++import Control.Monad {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import System.Environment {- base -}+import System.Exit {- base -}++import qualified Data.List.Split as Split {- split -}++import qualified Music.Theory.Either as T {- hmt-base -}+import qualified Music.Theory.Read as T {- hmt-base -}++{- | (Key,Value)++Key does not include leading '--'.+-}+type Opt = (String,String)++-- | (Key,Default-Value,Type,Note)+type OptUsr = (String,String,String,String)++-- | Re-write default values at OptUsr.+opt_usr_rw_def :: [Opt] -> [OptUsr] -> [OptUsr]+opt_usr_rw_def rw =+  let f (k,v,ty,dsc) = case lookup k rw of+                         Just v' -> (k,v',ty,dsc)+                         Nothing -> (k,v,ty,dsc)+  in map f++-- | OptUsr to Opt.+opt_plain :: OptUsr -> Opt+opt_plain (k,v,_,_) = (k,v)++-- | OptUsr to help string, indent is two spaces.+opt_usr_help :: OptUsr -> String+opt_usr_help (k,v,t,n) = concat ["  ",k,":",t," -- ",n,"; default=",if null v then "Nil" else v]++-- | 'unlines' of 'opt_usr_help'+opt_help :: [OptUsr] -> String+opt_help = unlines . map opt_usr_help++-- | Lookup Key in Opt, error if non-existing.+opt_get :: [Opt] -> String -> String+opt_get o k = fromMaybe (error ("opt_get: " ++ k)) (lookup k o)++-- | Variant that returns Nothing if the result is the empty string, else Just the result.+opt_get_nil :: [Opt] -> String -> Maybe String+opt_get_nil o k = let r = opt_get o k in if null r then Nothing else Just r++-- | 'read' of 'get_opt'+opt_read :: Read t => [Opt] -> String -> t+opt_read o = T.read_err . opt_get o++-- | Parse k or k=v string, else error.+opt_param_parse :: String -> Opt+opt_param_parse p =+  case Split.splitOn "=" p of+    [lhs] -> (lhs,"True")+    [lhs,rhs] -> (lhs,rhs)+    _ -> error ("opt_param_parse: " ++ p)++-- | Parse option string of form "--opt" or "--key=value".+--+-- > opt_parse "--opt" == Just ("opt","True")+-- > opt_parse "--key=value" == Just ("key","value")+opt_parse :: String -> Maybe Opt+opt_parse s =+  case s of+    '-':'-':p -> Just (opt_param_parse p)+    _ -> Nothing++-- | Parse option sequence, collating options and non-options.+--+-- > opt_set_parse (words "--a --b=c d") == ([("a","True"),("b","c")],["d"])+opt_set_parse :: [String] -> ([Opt],[String])+opt_set_parse =+  let f s = maybe (Right s) Left (opt_parse s)+  in T.partition_eithers . map f++-- | Left-biased Opt merge.+opt_merge :: [Opt] -> [Opt] -> [Opt]+opt_merge p q =+  let x = map fst p+  in p ++ filter (\(k,_) -> k `notElem` x) q++-- | Process argument list.+opt_proc :: [OptUsr] -> [String] -> ([Opt], [String])+opt_proc def arg =+  let (o,a) = opt_set_parse arg+  in (opt_merge o (map opt_plain def),a)++-- | Usage text+type OptHelp = [String]++-- | Format usage pre-amble and 'opt_help'.+opt_help_pp :: OptHelp -> [OptUsr] -> String+opt_help_pp usg def = unlines (usg ++ ["",opt_help def])++-- | Print help and exit.+opt_usage :: OptHelp -> [OptUsr] -> IO ()+opt_usage usg def = putStrLn (opt_help_pp usg def)  >> exitWith ExitSuccess++-- | Print help and error.+opt_error :: OptHelp -> [OptUsr] -> t+opt_error usg def = error (opt_help_pp usg def)++-- | Verify that all Opt have keys that are in OptUsr+opt_verify :: OptHelp -> [OptUsr] -> [Opt] -> IO ()+opt_verify usg def =+  let k_set = map (fst . opt_plain) def+      f (k,_) = if k `elem` k_set+                then return ()+                else putStrLn ("Unknown Key: " ++ k ++ "\n") >> opt_usage usg def+  in mapM_ f++-- | 'opt_set_parse' and maybe 'opt_verify' and 'opt_merge' of 'getArgs'.+--   If arguments include -h or --help run 'opt_usage'+opt_get_arg :: Bool -> OptHelp -> [OptUsr] -> IO ([Opt],[String])+opt_get_arg chk usg def = do+  a <- getArgs+  when ("-h" `elem` a || "--help" `elem` a) (opt_usage usg def)+  let (o,p) = opt_set_parse a+  when chk (opt_verify usg def o)+  return (opt_merge o (map opt_plain def),p)++-- | Parse param set, one parameter per line.+--+-- > opt_param_set_parse "a\nb=c" == [("a","True"),("b","c")]+opt_param_set_parse :: String -> [Opt]+opt_param_set_parse = map opt_param_parse . lines++-- | Simple scanner over argument list.+opt_scan :: [String] -> String -> Maybe String+opt_scan a k =+  let (o,_) = opt_set_parse a+  in fmap snd (find ((== k) . fst) o)++-- | Scanner with default value.+opt_scan_def :: [String] -> (String,String) -> String+opt_scan_def a (k,v) = fromMaybe v (opt_scan a k)++-- | Reading scanner with default value.+opt_scan_read :: Read t => [String] -> (String,t) -> t+opt_scan_read a (k,v) = maybe v read (opt_scan a k)

@@ -0,0 +1,42 @@+-- | 'Ordering' functions+module Music.Theory.Ord where++-- | Minimum by /f/.+min_by :: Ord a => (t -> a) -> t -> t -> t+min_by f p q = if f p <= f q then p else q++-- | Specialised 'fromEnum'.+ord_to_int :: Ordering -> Int+ord_to_int = fromEnum++-- | Specialised 'toEnum'.+int_to_ord :: Int -> Ordering+int_to_ord = toEnum++-- | Invert 'Ordering'.+--+-- > map ord_invert [LT,EQ,GT] == [GT,EQ,LT]+ord_invert :: Ordering -> Ordering+ord_invert x =+    case x of+      LT -> GT+      EQ -> EQ+      GT -> LT++-- | Given 'Ordering', re-order pair,+order_pair :: Ordering -> (t,t) -> (t,t)+order_pair o (x,y) =+    case o of+      LT -> (x,y)+      EQ -> (x,y)+      GT -> (y,x)++-- | Sort a pair of equal type values using given comparison function.+--+-- > sort_pair compare ('b','a') == ('a','b')+sort_pair :: (t -> t -> Ordering) -> (t,t) -> (t,t)+sort_pair fn (x,y) = order_pair (fn x y) (x,y)++-- | Variant where the comparison function may not compute a value.+sort_pair_m :: (t -> t -> Maybe Ordering) -> (t,t) -> Maybe (t,t)+sort_pair_m fn (x,y) = fmap (`order_pair` (x,y)) (fn x y)

@@ -0,0 +1,231 @@+-- | Permutation functions.+module Music.Theory.Permutations where++import Data.List {- base -}+import qualified Numeric {- base -}++import qualified Music.Theory.List as L {- hmt-base -}++-- | Factorial function.+--+-- > (factorial 20,maxBound::Int)+factorial :: Integral n => n -> n+factorial n = product [1..n]++-- | Number of /k/ element permutations of a set of /n/ elements.+--+-- > let f = nk_permutations in (f 3 2,f 3 3,f 4 3,f 4 4,f 13 3,f 12 12) == (6,6,24,24,1716,479001600)+nk_permutations :: Integral a => a -> a -> a+nk_permutations n k = factorial n  `div` factorial (n - k)++-- | Number of /nk/ permutations where /n/ '==' /k/.+--+-- > map n_permutations [1..8] == [1,2,6,24,120,720,5040,40320]+-- > n_permutations 12 == 479001600+-- > n_permutations 16 `div` 1000000 == 20922789+n_permutations :: (Integral a) => a -> a+n_permutations n = nk_permutations n n++-- | Permutation given as a zero-indexed list of destination indices.+type Permutation = [Int]++{- | Generate the permutation from /p/ to /q/, ie. the permutation+     that, when applied to /p/, gives /q/.++> p = permutation "abc" "bac"+> p == [1,0,2]+> apply_permutation p "abc" == "bac"+-}+permutation :: Eq t => [t] -> [t] -> Permutation+permutation p q =+    let f x = L.elem_index_unique x p+    in map f q++-- | Permutation to list of swaps, ie. 'zip' [0..]+--+-- > permutation_to_swaps [0,2,1,3] == [(0,0),(1,2),(2,1),(3,3)]+permutation_to_swaps :: Permutation -> [(Int,Int)]+permutation_to_swaps = zip [0..]++-- | Inverse of 'permutation_to_swaps', ie. 'map' 'snd' '.' 'sort'+swaps_to_permutation :: [(Int,Int)] -> Permutation+swaps_to_permutation = map snd . sort++-- | List of cycles to list of swaps.+--+-- > cycles_to_swaps [[0,2],[1],[3,4]] == [(0,2),(1,1),(2,0),(3,4),(4,3)]+cycles_to_swaps :: [[Int]] -> [(Int,Int)]+cycles_to_swaps = sort . concatMap (L.adj2_cyclic 1)++-- > swaps_to_cycles [(0,2),(1,1),(2,0),(3,4),(4,3)] == [[0,2],[1],[3,4]]+swaps_to_cycles :: [(Int, Int)] -> [[Int]]+swaps_to_cycles s =+  let z = length s+      next k = L.lookup_err k s+      trace k =+        let f r i = let j = next i in if j == k then reverse r else f (j : r) j+        in f [k] k+      step r k =+        if k == z+        then reverse r+        else if k `elem` concat r then step r (k + 1) else step (trace k : r) (k + 1)+  in step [] 0++{- | Apply permutation /f/ to /p/.++> let p = permutation [1..4] [4,3,2,1]+> p == [3,2,1,0]+> apply_permutation p [1..4] == [4,3,2,1]+-}+apply_permutation :: Permutation -> [t] -> [t]+apply_permutation f p = map (p !!) f++-- | Composition of 'apply_permutation' and 'from_cycles_zero_indexed'.+--+-- > apply_permutation_c_zero_indexed [[0,3],[1,2]] [1..4] == [4,3,2,1]+-- > apply_permutation_c_zero_indexed [[0,2],[1],[3,4]] [1..5] == [3,2,1,5,4]+-- > apply_permutation_c_zero_indexed [[0,1,4],[2,3]] [1..5] == [2,5,4,3,1]+-- > apply_permutation_c_zero_indexed [[0,1,3],[2,4]] [1..5] == [2,4,5,1,3]+apply_permutation_c_zero_indexed :: [[Int]] -> [a] -> [a]+apply_permutation_c_zero_indexed = apply_permutation . from_cycles_zero_indexed++-- > p_inverse [2,7,4,9,8,3,5,0,6,1] == [7,9,0,5,2,6,8,1,4,3]+p_inverse :: Permutation -> Permutation+p_inverse = map snd . sort . flip zip [0..]++p_cycles :: Permutation -> [[Int]]+p_cycles = swaps_to_cycles . permutation_to_swaps++{- | True if the inverse of /p/ is /p/.++> non_invertible [1,0,2] == True+> non_invertible [2,7,4,9,8,3,5,0,6,1] == False++> let p = permutation [1..4] [4,3,2,1]+> non_invertible p == True && p_cycles p == [[0,3],[1,2]]+-}+non_invertible :: Permutation -> Bool+non_invertible p = p == p_inverse p++-- | Generate a permutation from the cycles /c/ (zero-indexed)+--+-- > apply_permutation (from_cycles_zero_indexed [[0,1,2,3]]) [1..4] == [2,3,4,1]+from_cycles_zero_indexed :: [[Int]] -> Permutation+from_cycles_zero_indexed = swaps_to_permutation . cycles_to_swaps++from_cycles_one_indexed :: [[Int]] -> Permutation+from_cycles_one_indexed = from_cycles_zero_indexed . map (map (subtract 1))++-- | Generate all permutations of size /n/ (naive)+--+-- > let r = [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]+-- > map one_line (permutations_n 3) == r+permutations_n :: Int -> [Permutation]+permutations_n n =+  let minus [] _ = []+      minus (x:xs) i = if x < i then x : minus xs i else xs+      f [] = [[]]+      f xs = [i : ys | i <- xs , ys <- f (xs `minus` i)]+  in case n of+       0 -> []+       1 -> [[0]]+       _ -> f [0 .. n - 1]++p_size :: Permutation -> Int+p_size = length++{- | Composition of /q/ then /p/.++> let p = from_cycles_zero_indexed [[0,2],[1],[3,4]]+> let q = from_cycles_zero_indexed [[0,1,4],[2,3]]+> let r = p `compose` q+> apply_permutation r [1,2,3,4,5] == [2,4,5,1,3]+-}+compose :: Permutation -> Permutation -> Permutation+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++-- | One-indexed 'p_cycles'+cycles_one_indexed :: Permutation -> [[Int]]+cycles_one_indexed = map (map (+ 1)) . p_cycles++{- | 'flip' of 'compose'++> cycles_one_indexed (from_cycles_one_indexed [[1,5],[2,3,6],[4]] `permutation_mul` from_cycles_one_indexed [[1,6,4],[2],[3,5]])+-}+permutation_mul :: Permutation -> Permutation -> Permutation+permutation_mul p q = compose q p++-- | Two line notation of /p/.+--+-- > two_line (permutation [0,1,3] [1,0,3]) == ([1,2,3],[2,1,3])+two_line :: Permutation -> ([Int],[Int])+two_line p =+    let n = p_size p+        i = [1..n]+    in (i,apply_permutation p i)++-- | One line notation of /p/.+--+-- > one_line (permutation [0,1,3] [1,0,3]) == [2,1,3]+--+-- > let r = [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]+-- > map one_line (permutations_n 3) == r+one_line :: Permutation -> [Int]+one_line = snd . two_line++-- | Variant of 'one_line' that produces a compact string.+--+-- > one_line_compact (permutation [0,1,3] [1,0,3]) == "213"+--+-- > let p = permutations_n 3+-- > unwords (map one_line_compact p) == "123 132 213 231 312 321"+one_line_compact :: Permutation -> String+one_line_compact =+    let f n = if n >= 0 && n <= 15+              then Numeric.showHex n ""+              else error "one_line_compact:not(0-15)"+    in concatMap f . one_line++-- | Multiplication table of symmetric group /n/.+--+-- > unlines (map (unwords . map one_line_compact) (multiplication_table 3))+--+-- @+-- ==> 123 132 213 231 312 321+--     132 123 312 321 213 231+--     213 231 123 132 321 312+--     231 213 321 312 123 132+--     312 321 132 123 231 213+--     321 312 231 213 132 123+-- @+multiplication_table :: Int -> [[Permutation]]+multiplication_table n =+    let ps = permutations_n n+        f p = map (compose p) ps+    in map f ps++{-++let q = permutation [1..4] [2,3,4,1] -- [[0,1,2,3]]+(q,non_invertible q,p_cycles q,apply_permutation q [1..4])++let p = permutation [1..5] [3,2,1,5,4] -- [[0,2],[1],[3,4]]+let q = permutation [1..5] [2,5,4,3,1] -- [[0,1,4],[2,3]]+let r = permutation [1..5] [2,4,5,1,3] -- [[0,1,3],[2,4]]+(non_invertible p,p_cycles p,apply_permutation p [1..5])+(non_invertible q,p_cycles q,apply_permutation q [1..5])+(non_invertible r,p_cycles r,apply_permutation r [1..5])++map p_cycles (permutations_n 3)+map p_cycles (permutations_n 4)++import Data.List {- base -}+partition not (map non_invertible (permutations_n 4))+putStrLn $ unlines $ map unwords $ permutations ["A0","A1","B0"]++-}

@@ -0,0 +1,197 @@+-- | Read functions.+module Music.Theory.Read where++import Data.Char {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -}+import Data.Word {- base -}+import Numeric {- base -}++-- | Transform 'ReadS' function into precise 'Read' function.+-- Requires using all the input to produce a single token.  The only+-- exception is a singular trailing white space character.+reads_to_read_precise :: ReadS t -> (String -> Maybe t)+reads_to_read_precise f s =+    case f s of+      [(r,[])] -> Just r+      [(r,[c])] -> if isSpace c then Just r else Nothing+      _ -> Nothing++-- | Error variant of 'reads_to_read_precise'.+reads_to_read_precise_err :: String -> ReadS t -> String -> t+reads_to_read_precise_err err f =+    fromMaybe (error ("reads_to_read_precise_err:" ++ err)) .+    reads_to_read_precise f++-- | 'reads_to_read_precise' of 'reads'.+--+-- > read_maybe "1.0" :: Maybe Int+-- > read_maybe "1.0" :: Maybe Float+read_maybe :: Read a => String -> Maybe a+read_maybe = reads_to_read_precise reads++-- | Variant of 'read_maybe' with default value.+--+-- > map (read_def 0) ["2","2:","2\n"] == [2,0,2]+read_def :: Read a => a -> String -> a+read_def x s = fromMaybe x (read_maybe s)++-- | Variant of 'read_maybe' that errors on 'Nothing', printing message.+read_err_msg :: Read a => String -> String -> a+read_err_msg msg s = fromMaybe (error ("read_err: " ++ msg ++ ": " ++ s)) (read_maybe s)++-- | Default message.+read_err :: Read a => String -> a+read_err = read_err_msg "read_maybe failed"++-- | Variant of 'reads' requiring exact match, no trailing white space.+--+-- > map reads_exact ["1.5","2,5"] == [Just 1.5,Nothing]+reads_exact :: Read a => String -> Maybe a+reads_exact s =+    case reads s of+      [(r,"")] -> Just r+      _ -> Nothing++-- | Variant of 'reads_exact' that errors on failure.+reads_exact_err :: Read a => String -> String -> a+reads_exact_err err_txt str =+    let err = error ("reads: " ++ err_txt ++ ": " ++ str)+    in fromMaybe err (reads_exact str)++-- * Type specific variants++-- | Allow commas as thousand separators.+--+-- > let r = [Just 123456,Just 123456,Nothing,Just 123456789]+-- > map read_integral_allow_commas_maybe ["123456","123,456","1234,56","123,456,789"] == r+read_integral_allow_commas_maybe :: Read i => String -> Maybe i+read_integral_allow_commas_maybe s =+    let c = filter ((== ',') . fst) (zip (reverse s) [0..])+    in if null c+       then read_maybe s+       else if map snd c `isPrefixOf` [3::Int,7..]+            then read_maybe (filter (/= ',') s)+            else Nothing++read_integral_allow_commas_err :: (Integral i,Read i) => String -> i+read_integral_allow_commas_err s =+    let err = error ("read_integral_allow_commas: misplaced commas: " ++ s)+    in fromMaybe err (read_integral_allow_commas_maybe s)++-- | Type specialised.+--+-- > map read_int_allow_commas ["123456","123,456","123,456,789"] == [123456,123456,123456789]+read_int_allow_commas :: String -> Int+read_int_allow_commas = read_integral_allow_commas_err++-- | Read a ratio where the division is given by @/@ instead of @%@+-- and the integers allow commas.+--+-- > map read_ratio_with_div_err ["123,456/7","123,456,789"] == [123456/7,123456789]+read_ratio_with_div_err :: (Integral i, Read i) => String -> Ratio i+read_ratio_with_div_err s =+    let f = read_integral_allow_commas_err+    in case break (== '/') s of+         (n,'/':d) -> f n % f d+         _ -> read_integral_allow_commas_err s % 1++-- | Read 'Ratio', allow commas for thousand separators.+--+-- > read_ratio_allow_commas_err "327,680" "177,147" == 327680 / 177147+read_ratio_allow_commas_err :: (Integral i,Read i) => String -> String -> Ratio i+read_ratio_allow_commas_err n d = let f = read_integral_allow_commas_err in f n % f d++-- | Delete trailing @.@, 'read' fails for @700.@.+delete_trailing_point :: String -> String+delete_trailing_point s =+    case reverse s of+      '.':s' -> reverse s'+      _ -> s++-- | 'read_err' disallows trailing decimal points.+--+-- > map read_fractional_allow_trailing_point_err ["123.","123.4"] == [123.0,123.4]+read_fractional_allow_trailing_point_err :: Read n => String -> n+read_fractional_allow_trailing_point_err = read_err . delete_trailing_point++-- * Plain type specialisations++-- | Type specialised 'read_maybe'.+--+-- > map read_maybe_int ["2","2:","2\n","x"] == [Just 2,Nothing,Just 2,Nothing]+read_maybe_int :: String -> Maybe Int+read_maybe_int = read_maybe++-- | Type specialised 'read_err'.+read_int :: String -> Int+read_int = read_err++-- | Type specialised 'read_maybe'.+read_maybe_double :: String -> Maybe Double+read_maybe_double = read_maybe++-- | Type specialised 'read_err'.+read_double :: String -> Double+read_double = read_err++-- | Type specialised 'read_maybe'.+--+-- > map read_maybe_rational ["1","1%2","1/2"] == [Nothing,Just (1/2),Nothing]+read_maybe_rational :: String -> Maybe Rational+read_maybe_rational = read_maybe++-- | Type specialised 'read_err'.+--+-- > read_rational "1%4"+read_rational :: String -> Rational+read_rational = read_err++-- * Numeric variants++-- | Read binary integer.+--+-- > mapMaybe read_bin (words "000 001 010 011 100 101 110 111") == [0 .. 7]+read_bin :: Integral a => String -> Maybe a+read_bin = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt++-- | Erroring variant.+read_bin_err :: Integral a => String -> a+read_bin_err = fromMaybe (error "read_bin") . read_bin++-- * HEX++-- | Error variant of 'readHex'.+--+-- > read_hex_err "F0B0" == 61616+read_hex_err :: (Eq n, Integral n) => String -> n+read_hex_err = reads_to_read_precise_err "readHex" readHex++-- | Read hex value from string of at most /k/ places.+read_hex_sz :: (Eq n, Integral n) => Int -> String -> n+read_hex_sz k str =+  if length str > k+  then error "read_hex_sz? = > K"+  else case readHex str of+         [(r,[])] -> r+         _ -> error "read_hex_sz? = PARSE"++-- | Read hexadecimal representation of 32-bit unsigned word.+--+-- > map read_hex_word32 ["00000000","12345678","FFFFFFFF"] == [minBound,305419896,maxBound]+read_hex_word32 :: String -> Word32+read_hex_word32 = read_hex_sz 8++-- * Rational++-- | Parser for 'rational_pp'.+--+-- > map rational_parse ["1","3/2","5/4","2"] == [1,3/2,5/4,2]+-- > rational_parse "" == undefined+rational_parse :: (Read t,Integral t) => String -> Ratio t+rational_parse s =+  case break (== '/') s of+    ([],_) -> error "rational_parse"+    (n,[]) -> read n % 1+    (n,_:d) -> read n % read d

@@ -0,0 +1,129 @@+-- | Show functions.+module Music.Theory.Show where++import Data.Char {- base -}+import Data.Ratio {- base -}+import Numeric {- base -}++import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Math as T {- hmt-base -}+import qualified Music.Theory.Math.Convert as T {- hmt-base -}++-- * DIFF++-- | Show positive and negative values always with sign, maybe show zero, maybe right justify.+--+-- > map (num_diff_str_opt (True,2)) [-2,-1,0,1,2] == ["-2","-1"," 0","+1","+2"]+num_diff_str_opt :: (Ord a, Num a, Show a) => (Bool,Int) -> a -> String+num_diff_str_opt (wr_0,k) n =+  let r = case compare n 0 of+            LT -> '-' : show (abs n)+            EQ -> if wr_0 then "0" else ""+            GT -> '+' : show n+  in if k > 0 then T.pad_left ' ' k r else r++-- | Show /only/ positive and negative values, always with sign.+--+-- > map num_diff_str [-2,-1,0,1,2] == ["-2","-1","","+1","+2"]+-- > map show [-2,-1,0,1,2] == ["-2","-1","0","1","2"]+num_diff_str :: (Num a, Ord a, Show a) => a -> String+num_diff_str = num_diff_str_opt (False,0)++-- * RATIONAL++-- | Pretty printer for 'Rational' using @/@ and eliding denominators of @1@.+--+-- > map rational_pp [1,3/2,5/4,2] == ["1","3/2","5/4","2"]+rational_pp :: (Show a,Integral a) => Ratio a -> String+rational_pp r =+    let n = numerator r+        d = denominator r+    in if d == 1+       then show n+       else concat [show n,"/",show d]++-- | Pretty print ratio as @:@ separated integers, if /nil/ is True elide unit denominator.+--+-- > map (ratio_pp_opt True) [1,3/2,2] == ["1","3:2","2"]+ratio_pp_opt :: Bool -> Rational -> String+ratio_pp_opt nil r =+  let f :: (Integer,Integer) -> String+      f (n,d) = concat [show n,":",show d]+  in case T.rational_nd r of+       (n,1) -> if nil then show n else f (n,1)+       x -> f x++-- | Pretty print ratio as @:@ separated integers.+--+-- > map ratio_pp [1,3/2,2] == ["1:1","3:2","2:1"]+ratio_pp :: Rational -> String+ratio_pp = ratio_pp_opt False++-- | Show rational to /n/ decimal places.+--+-- > let r = approxRational pi 1e-100+-- > r == 884279719003555 / 281474976710656+-- > show_rational_decimal 12 r == "3.141592653590"+-- > show_rational_decimal 3 (-100) == "-100.000"+show_rational_decimal :: Int -> Rational -> String+show_rational_decimal n = double_pp n . fromRational++-- * REAL++-- | Show /r/ as float to /k/ places.+--+-- > real_pp 4 (1/3 :: Rational) == "0.3333"+-- > map (real_pp 4) [1,1.1,1.12,1.123,1.1234,1/0,sqrt (-1)]+real_pp :: Real t => Int -> t -> String+real_pp k = realfloat_pp k . T.real_to_double++-- | Variant that writes `∞` for Infinity.+--+-- > putStrLn $ unwords $ map (real_pp_unicode 4) [1/0,-1/0]+real_pp_unicode :: Real t => Int -> t -> [Char]+real_pp_unicode k r =+  case real_pp k r of+    "Infinity" -> "∞"+    "-Infinity" -> "-∞"+    s -> s++-- | Prints /n/ as integral or to at most /k/ decimal places. Does not print -0.+--+-- > real_pp_trunc 4 (1/3 :: Rational) == "0.3333"+-- > map (real_pp_trunc 4) [1,1.1,1.12,1.123,1.1234] == ["1","1.1","1.12","1.123","1.1234"]+-- > map (real_pp_trunc 4) [1.00009,1.00001] == ["1.0001","1"]+-- > map (real_pp_trunc 2) [59.999,60.001,-0.00,-0.001]+real_pp_trunc :: Real t => Int -> t -> String+real_pp_trunc k n =+  case break (== '.') (real_pp k n) of+    (i,[]) -> i+    (i,j) -> case T.drop_while_end (== '0') j of+               "." -> if i == "-0" then "0" else i+               z -> i ++ z++-- | Variant of 'showFFloat'.  The 'Show' instance for floats resorts+-- to exponential notation very readily.+--+-- > [show 0.01,realfloat_pp 2 0.01] == ["1.0e-2","0.01"]+-- > map (realfloat_pp 4) [1,1.1,1.12,1.123,1.1234,1/0,sqrt (-1)]+realfloat_pp :: RealFloat a => Int -> a -> String+realfloat_pp k n = showFFloat (Just k) n ""++-- | Type specialised 'realfloat_pp'.+float_pp :: Int -> Float -> String+float_pp = realfloat_pp++-- | Type specialised 'realfloat_pp'.+--+-- > double_pp 4 0+double_pp :: Int -> Double -> String+double_pp = realfloat_pp++-- * BIN++-- | Read binary integer.+--+-- > unwords (map (show_bin Nothing) [0 .. 7]) == "0 1 10 11 100 101 110 111"+-- > unwords (map (show_bin (Just 3)) [0 .. 7]) == "000 001 010 011 100 101 110 111"+show_bin :: (Integral i,Show i) => Maybe Int -> i -> String+show_bin k n = maybe id (T.pad_left '0') k (showIntAtBase 2 intToDigit n "")

@@ -0,0 +1,70 @@+-- | String functions.+module Music.Theory.String where++import Data.Char {- base -}+import Data.List {- base -}++-- | Case-insensitive '=='.+--+-- > map (str_eq_ci "ci") (words "CI ci Ci cI")+str_eq_ci :: String -> String -> Bool+str_eq_ci x y = map toUpper x == map toUpper y++-- | Remove @\r@.+filter_cr :: String -> String+filter_cr = filter (not . (==) '\r')++-- | Delete trailing 'Char' where 'isSpace' holds.+--+-- > delete_trailing_whitespace "   str   " == "   str"+-- > delete_trailing_whitespace "\t\n        \t\n" == ""+delete_trailing_whitespace :: String -> String+delete_trailing_whitespace = reverse . dropWhile isSpace . reverse++{- | Variant of 'unwords' that does not write spaces for NIL elements.++> unwords_nil [] == ""+> unwords_nil ["a"] == "a"+> unwords_nil ["a",""] == "a"+> unwords_nil ["a","b"] == "a b"+> unwords_nil ["a","","b"] == "a b"+> unwords_nil ["a","","","b"] == "a b"+> unwords_nil ["a","b",""] == "a b"+> unwords_nil ["a","b","",""] == "a b"+> unwords_nil ["","a","b"] == "a b"+> unwords_nil ["","","a","b"] == "a b"+-}+unwords_nil :: [String] -> String+unwords_nil = unwords . filter (not . null)++-- | Variant of 'unlines' that does not write empty lines for NIL elements.+unlines_nil :: [String] -> String+unlines_nil = unlines . filter (not . null)++{- | unlines without a trailing newline.++> unlines (words "a b c") == "a\nb\nc\n"+> unlinesNoTrailingNewline (words "a b c") == "a\nb\nc"+-}+unlinesNoTrailingNewline :: [String] -> String+unlinesNoTrailingNewline = intercalate "\n"++{- | Capitalise first character of word.++> capitalise "freqShift" == "FreqShift"+-}+capitalise :: String -> String+capitalise x = toUpper (head x) : tail x++{- | Downcase first character of word.++> unCapitalise "FreqShift" == "freqShift"+-}+unCapitalise :: String -> String+unCapitalise x = toLower (head x) : tail x++-- | Apply function at each line of string.+--+-- > on_lines reverse "ab\ncde\nfg" == "ba\nedc\ngf\n"+on_lines :: (String -> String) -> String -> String+on_lines f = unlines . map f . lines

@@ -0,0 +1,183 @@+-- | Ordinary timing durations, in H:M:S:m (Hours:Minutes:Seconds:milliseconds)+module Music.Theory.Time.Duration where++import Text.Printf {- base -}++import qualified Data.List.Split as Split {- split -}++-- | 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.+     The notation writes seconds fractionally, and allows hours and minutes to be elided if zero.+-}+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 Split.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'.+     Inverse of read_duration.+     Hours and minutes are always shown, even if zero.++> show_duration (Duration 1 35 5 250) == "01:35:05.250"+> show (Duration 1 15 0 000) == "01:15:00.000"+> show (Duration 0 0 3 500) == "00:00:03.500"+-}+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++-- | If minutes is not in (0,59) then edit hours.+normalise_minutes :: Duration -> Duration+normalise_minutes (Duration h m s ms) =+    let (h',m') = m `divMod` 60+    in Duration (h + h') m' s ms++-- | If seconds is not in (0,59) then edit minutes.+normalise_seconds :: Duration -> Duration+normalise_seconds (Duration h m s ms) =+    let (m',s') = s `divMod` 60+    in Duration h (m + m') s' ms++-- | If milliseconds is not in (0,999) then edit seconds.+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 so that all parts are in normal ranges.+normalise_duration :: Duration -> Duration+normalise_duration =+    normalise_minutes .+    normalise_seconds .+    normalise_milliseconds++{- | Extract 'Duration' tuple applying filter function at each element++> duration_to_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 as fractional hours.++> 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 as fractional minutes.++> 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 as fractional seconds.++> duration_to_seconds (read "01:35:05.250") == 5705.25+-}+duration_to_seconds :: Fractional n => Duration -> n+duration_to_seconds = (* 60) . duration_to_minutes++{- | Inverse of duration_to_hours.++> 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++-- | Inverse of duration_to_minutes.+minutes_to_duration :: RealFrac a => a -> Duration+minutes_to_duration n = hours_to_duration (n / 60)++-- | Inverse of duration_to_seconds.+seconds_to_duration :: RealFrac a => a -> Duration+seconds_to_duration n = minutes_to_duration (n / 60)++-- | Empty (zero) duration.+nil_duration :: Duration+nil_duration = Duration 0 0 0 0++-- | Negate the leftmost non-zero element of Duration.+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'++{- | Difference between two durations as a duration.+     Implemented by translation to and from Rational fractional hours.++> 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 -> Rational+        (p',q') = (f p,f q)+        g = normalise_duration . hours_to_duration+    in case compare p' q' of+         LT -> negate_duration (g (q' - p'))+         EQ -> nil_duration+         GT -> g (p' - q')

@@ -0,0 +1,481 @@+{- | Ordinary time and duration notations.+     In terms of Weeks, Days, Hours, Minutes, Second and Centiseconds.+     c.f. "Music.Theory.Time.Duration".+-}+module Music.Theory.Time.Notation where++import Text.Printf {- base -}++import qualified Data.List.Split as Split {- split -}+import qualified Data.Time as Time {- time -}++import qualified Music.Theory.Function as Function {- hmt-base -}+import qualified Music.Theory.List as List {- hmt-base -}++-- * Integral types++-- | Week, one-indexed, ie. 1-52+type Week = Int++-- | Week, one-indexed, ie. 1-31+type Day = Int++-- | Hour, zero-indexed, ie. 0-23+type Hour = Int++-- | Minute, zero-indexed, ie. 0-59+type Min = Int++-- | Second, zero-indexed, ie. 0-59+type Sec = Int++-- | Centi-seconds, zero-indexed, ie. 0-99+type Csec = Int -- (0-99)++-- * Composite types++-- | Minutes, seconds as @(min,sec)@+type MinSec = (Min,Sec)++-- | Generic MinSec+type GMinSec n = (n,n)++-- | Minutes, seconds, centi-seconds as @(min,sec,csec)@+type MinCsec = (Min,Sec,Csec)++-- | Generic MinCsec+type GMinCsec n = (n,n,n)++-- | (Hours,Minutes,Seconds)+type Hms = (Hour,Min,Sec)++-- | (Days,Hours,Minutes,Seconds)+type Dhms = (Day,Hour,Min,Sec)++-- * Fractional types++-- | Fractional days.+type FDay = Double++-- | Fractional hour, ie. 1.50 is one and a half hours, ie. 1 hour and 30 minutes.+type FHour = Double++-- | Fractional minute, ie. 1.50 is one and a half minutes, ie. 1 minute and 30 seconds, cf. 'FMinSec'+type FMin = Double++-- | Fractional seconds.+type FSec = Double++-- | Fractional minutes and seconds (mm.ss, ie. 01.45 is 1 minute and 45 seconds).+type FMinSec = Double++-- * Time.UTCTime format strings.++-- | 'Time.parseTimeOrError' with 'Time.defaultTimeLocale'.+parse_time_str :: Time.ParseTime t => String -> String -> t+parse_time_str = Time.parseTimeOrError True Time.defaultTimeLocale++format_time_str :: Time.FormatTime t => String -> t -> String+format_time_str = Time.formatTime Time.defaultTimeLocale++-- * Iso-8601++-- | Parse date in ISO-8601 extended (@YYYY-MM-DD@) or basic (@YYYYMMDD@) form.+--+-- > Time.toGregorian (Time.utctDay (parse_iso8601_date "2011-10-09")) == (2011,10,09)+-- > Time.toGregorian (Time.utctDay (parse_iso8601_date "20190803")) == (2019,08,03)+parse_iso8601_date :: String -> Time.UTCTime+parse_iso8601_date s =+  case length s of+    8 -> parse_time_str "%Y%m%d" s -- basic+    10 -> parse_time_str "%F" s -- extended+    _ -> error "parse_iso8601_date?"++-- | Format date in ISO-8601 form.+--+-- > format_iso8601_date True (parse_iso8601_date "2011-10-09") == "2011-10-09"+-- > format_iso8601_date False (parse_iso8601_date "20190803") == "20190803"+format_iso8601_date :: Time.FormatTime t => Bool -> t -> String+format_iso8601_date ext = if ext then format_time_str "%F" else format_time_str "%Y%m%d"++{- | Format date in ISO-8601 (@YYYY-WWW@) form.++> r = ["2016-W52","2011-W40"]+> map (format_iso8601_week . parse_iso8601_date) ["2017-01-01","2011-10-09"] == r++-}+format_iso8601_week :: Time.FormatTime t => t -> String+format_iso8601_week = format_time_str "%G-W%V"++-- | Parse ISO-8601 time is extended (@HH:MM:SS@) or basic (@HHMMSS@) form.+--+-- > format_iso8601_time True (parse_iso8601_time "21:44:00") == "21:44:00"+-- > format_iso8601_time False (parse_iso8601_time "172511") == "172511"+parse_iso8601_time :: String -> Time.UTCTime+parse_iso8601_time s =+  case length s of+    6 -> parse_time_str "%H%M%S" s -- basic+    8 -> parse_time_str "%H:%M:%S" s -- extended+    _ -> error "parse_iso8601_time?"++-- | Format time in ISO-8601 form.+--+-- > format_iso8601_time True (parse_iso8601_date_time "2011-10-09T21:44:00") == "21:44:00"+-- > format_iso8601_time False (parse_iso8601_date_time "20190803T172511") == "172511"+format_iso8601_time :: Time.FormatTime t => Bool -> t -> String+format_iso8601_time ext = format_time_str (if ext then "%H:%M:%S" else "%H%M%S")++-- | Parse date and time in extended or basic forms.+--+-- > Time.utctDayTime (parse_iso8601_date_time "2011-10-09T21:44:00") == Time.secondsToDiffTime 78240+-- > Time.utctDayTime (parse_iso8601_date_time "20190803T172511") == Time.secondsToDiffTime 62711+parse_iso8601_date_time :: String -> Time.UTCTime+parse_iso8601_date_time s =+  case length s of+    15 -> parse_time_str "%Y%m%dT%H%M%S" s -- basic+    19 -> parse_time_str "%FT%H:%M:%S" s -- extended+    _ -> error ("parse_iso8601_date_time: " ++ s)++{- | Format date in @YYYY-MM-DD@ and time in @HH:MM:SS@ forms.++> t = parse_iso8601_date_time "2011-10-09T21:44:00"+> format_iso8601_date_time True t == "2011-10-09T21:44:00"+> format_iso8601_date_time False t == "20111009T214400"++-}+format_iso8601_date_time :: Time.FormatTime t => Bool -> t -> String+format_iso8601_date_time ext = format_time_str (if ext then "%FT%H:%M:%S" else "%Y%m%dT%H%M%S")++-- * FMin++-- | 'fsec_to_minsec' . '*' 60+--+-- > fmin_to_minsec 6.48 == (6,29)+fmin_to_minsec :: FMin -> MinSec+fmin_to_minsec = fsec_to_minsec . (*) 60++-- * FSec++-- | Translate fractional seconds to picoseconds.+--+-- > fsec_to_picoseconds 78240.05+fsec_to_picoseconds :: FSec -> Integer+fsec_to_picoseconds s = floor (s * (10 ** 12))++fsec_to_difftime :: FSec -> Time.DiffTime+fsec_to_difftime = Time.picosecondsToDiffTime . fsec_to_picoseconds++-- * FMinSec++-- | Translate fractional minutes.seconds to picoseconds.+--+-- > map fminsec_to_fsec [0.45,15.355] == [45,935.5]+fminsec_to_fsec :: FMinSec -> FSec+fminsec_to_fsec n =+    let m = ffloor n+        s = (n - m) * 100+    in (m * 60) + s++fminsec_to_sec_generic :: (RealFrac f,Integral i) => f -> i+fminsec_to_sec_generic n =+    let m = floor n+        s = round ((n - fromIntegral m) * 100)+    in (m * 60) + s++-- | Fractional minutes are mm.ss, so that 15.35 is 15 minutes and 35 seconds.+--+-- > map fminsec_to_sec [0.45,15.35] == [45,935]+fminsec_to_sec :: FMinSec -> Sec+fminsec_to_sec = fminsec_to_sec_generic++-- > fsec_to_fminsec 935.5 == 15.355+fsec_to_fminsec :: FSec -> FMinSec+fsec_to_fminsec n =+    let m = ffloor (n / 60)+        s = n - (m * 60)+    in m + (s / 100)++-- > sec_to_fminsec 935 == 15.35+sec_to_fminsec :: Sec -> FMinSec+sec_to_fminsec n =+    let m = ffloor (fromIntegral n / 60)+        s = fromIntegral n - (m * 60)+    in m + (s / 100)++-- > fminsec_add 1.30 0.45 == 2.15+-- > fminsec_add 1.30 0.45 == 2.15+fminsec_add :: Function.BinOp FMinSec+fminsec_add p q = fsec_to_fminsec (fminsec_to_fsec p + fminsec_to_fsec q)++fminsec_sub :: Function.BinOp FMinSec+fminsec_sub p q = fsec_to_fminsec (fminsec_to_fsec p - fminsec_to_fsec q)++-- > fminsec_mul 0.45 2 == 1.30+fminsec_mul :: Function.BinOp FMinSec+fminsec_mul t n = fsec_to_fminsec (fminsec_to_fsec t * n)++-- * FHour++-- | Type specialised 'fromInteger' of 'floor'.+ffloor :: Double -> Double+ffloor = fromInteger . floor++-- | Fractional hour to (hours,minutes,seconds).+--+-- > fhour_to_hms 21.75 == (21,45,0)+fhour_to_hms :: FHour -> Hms+fhour_to_hms h =+    let m = (h - ffloor h) * 60+        s = (m - ffloor m) * 60+    in (floor h,floor m,round s)++-- | Hms to fractional hours.+--+-- > hms_to_fhour (21,45,0) == 21.75+hms_to_fhour :: Hms -> FHour+hms_to_fhour (h,m,s) = fromIntegral h + (fromIntegral m / 60) + (fromIntegral s / (60 * 60))++-- | Fractional hour to seconds.+--+-- > fhour_to_fsec 21.75 == 78300.0+fhour_to_fsec :: FHour -> FSec+fhour_to_fsec = (*) (60 * 60)++fhour_to_difftime :: FHour -> Time.DiffTime+fhour_to_difftime = fsec_to_difftime . fhour_to_fsec++-- * FDay++-- | Time in fractional days.+--+-- > round (utctime_to_fday (parse_iso8601_date_time "2011-10-09T09:00:00")) == 55843+-- > round (utctime_to_fday (parse_iso8601_date_time "2011-10-09T21:00:00")) == 55844+utctime_to_fday :: Time.UTCTime -> FDay+utctime_to_fday t =+    let d = Time.utctDay t+        d' = fromIntegral (Time.toModifiedJulianDay d)+        s = Time.utctDayTime t+        s_max = 86401+    in d' + (fromRational (toRational s) / s_max)++-- * DiffTime++-- | 'Time.DiffTime' in fractional seconds.+--+-- > difftime_to_fsec (hms_to_difftime (21,44,30)) == 78270+difftime_to_fsec :: Time.DiffTime -> FSec+difftime_to_fsec = fromRational . toRational++-- | 'Time.DiffTime' in fractional minutes.+--+-- > difftime_to_fmin (hms_to_difftime (21,44,30)) == 1304.5+difftime_to_fmin :: Time.DiffTime -> Double+difftime_to_fmin = (/ 60) . difftime_to_fsec++-- | 'Time.DiffTime' in fractional hours.+--+-- > difftime_to_fhour (hms_to_difftime (21,45,00)) == 21.75+difftime_to_fhour :: Time.DiffTime -> FHour+difftime_to_fhour = (/ 60) . difftime_to_fmin++hms_to_difftime :: Hms -> Time.DiffTime+hms_to_difftime = fhour_to_difftime . hms_to_fhour++-- * Hms++hms_to_sec :: Hms -> Sec+hms_to_sec (h,m,s) = h * 60 * 60 + m * 60 + s++-- | Seconds to (hours,minutes,seconds).+--+-- > map sec_to_hms [60-1,60+1,60*60-1,60*60+1] == [(0,0,59),(0,1,1),(0,59,59),(1,0,1)]+sec_to_hms :: Sec -> Hms+sec_to_hms s =+  let (h,s') = s `divMod` (60 * 60)+      (m,s'') = sec_to_minsec s'+  in (h,m,s'')++-- | 'Hms' pretty printer.+--+-- > map (hms_pp True) [(0,1,2),(1,2,3)] == ["01:02","01:02:03"]+hms_pp :: Bool -> Hms -> String+hms_pp trunc (h,m,s) =+  if trunc && h == 0+  then printf "%02d:%02d" m s+  else printf "%02d:%02d:%02d" h m s++-- * 'Hms' parser.+--+-- > hms_parse "0:01:00" == (0,1,0)+hms_parse :: String -> Hms+hms_parse x =+    case Split.splitOn ":" x of+      [h,m,s] -> (read h,read m,read s)+      _ -> error "parse_hms"++-- * MinSec++-- | 'divMod' by @60@.+--+-- > sec_to_minsec 123 == (2,3)+sec_to_minsec :: Integral n => n -> GMinSec n+sec_to_minsec = flip divMod 60++-- | Inverse of 'sec_minsec'.+--+-- > minsec_to_sec (2,3) == 123+minsec_to_sec :: Num n => GMinSec n -> n+minsec_to_sec (m,s) = m * 60 + s++-- | Convert /p/ and /q/ to seconds, apply /f/, and convert back to 'MinSec'.+minsec_binop :: Integral t => (t -> t -> t) -> GMinSec t -> GMinSec t -> GMinSec t+minsec_binop f p q = sec_to_minsec (f (minsec_to_sec p) (minsec_to_sec q))++-- | 'minsec_binop' '-', assumes /q/ precedes /p/.+--+-- > minsec_sub (2,35) (1,59) == (0,36)+minsec_sub :: Integral n => GMinSec n -> GMinSec n -> GMinSec n+minsec_sub = minsec_binop (-)++-- | 'minsec_binop' 'subtract', assumes /p/ precedes /q/.+--+-- > minsec_diff (1,59) (2,35) == (0,36)+minsec_diff :: Integral n => GMinSec n -> GMinSec n -> GMinSec n+minsec_diff = minsec_binop subtract++-- | 'minsec_binop' '+'.+--+-- > minsec_add (1,59) (2,35) == (4,34)+minsec_add :: Integral n => GMinSec n -> GMinSec n -> GMinSec n+minsec_add = minsec_binop (+)++-- | 'foldl' of 'minsec_add'+--+-- > minsec_sum [(1,59),(2,35),(4,34)] == (9,08)+minsec_sum :: Integral n => [GMinSec n] -> GMinSec n+minsec_sum = foldl minsec_add (0,0)++-- | 'round' fractional seconds to @(min,sec)@.+--+-- > map fsec_to_minsec [59.49,60,60.51] == [(0,59),(1,0),(1,1)]+fsec_to_minsec :: FSec -> MinSec+fsec_to_minsec = sec_to_minsec . round++-- | 'MinSec' pretty printer.+--+-- > map (minsec_pp . fsec_to_minsec) [59,61] == ["00:59","01:01"]+minsec_pp :: MinSec -> String+minsec_pp (m,s) = printf "%02d:%02d" m s++-- * 'MinSec' parser.+minsec_parse :: (Num n,Read n) => String -> GMinSec n+minsec_parse x =+    case Split.splitOn ":" x of+      [m,s] -> (read m,read s)+      _ -> error ("minsec_parse: " ++ x)++-- * MinCsec++-- | Fractional seconds to @(min,sec,csec)@, csec value is 'round'ed.+--+-- > map fsec_to_mincsec [1,1.5,4/3] == [(0,1,0),(0,1,50),(0,1,33)]+fsec_to_mincsec :: FSec -> MinCsec+fsec_to_mincsec tm =+    let tm' = floor tm+        (m,s) = sec_to_minsec tm'+        cs = round ((tm - fromIntegral tm') * 100)+    in (m,s,cs)++-- | Inverse of 'fsec_mincsec'.+mincsec_to_fsec :: Real n => GMinCsec n -> FSec+mincsec_to_fsec (m,s,cs) = realToFrac m * 60 + realToFrac s + (realToFrac cs / 100)++-- > map (mincsec_to_csec . fsec_to_mincsec) [1,6+2/3,123.45] == [100,667,12345]+mincsec_to_csec :: Num n => GMinCsec n -> n+mincsec_to_csec (m,s,cs) = m * 60 * 100 + s * 100 + cs++-- | Centi-seconds to 'MinCsec'.+--+-- > map csec_to_mincsec [123,12345] == [(0,1,23),(2,3,45)]+csec_to_mincsec :: Integral n => n -> GMinCsec n+csec_to_mincsec csec =+    let (m,cs) = csec `divMod` 6000+        (s,cs') = cs `divMod` 100+    in (m,s,cs')++-- | 'MinCsec' pretty printer, concise mode omits centiseconds when zero.+--+-- > map (mincsec_pp_opt True . fsec_to_mincsec) [1,60.5] == ["00:01","01:00.50"]+mincsec_pp_opt :: Bool -> MinCsec -> String+mincsec_pp_opt concise (m,s,cs) =+  if concise && cs == 0+  then printf "%02d:%02d" m s+  else printf "%02d:%02d.%02d" m s cs++-- | 'MinCsec' pretty printer.+--+-- > let r = ["00:01.00","00:06.67","02:03.45"]+-- > map (mincsec_pp . fsec_to_mincsec) [1,6+2/3,123.45] == r+mincsec_pp :: MinCsec -> String+mincsec_pp = mincsec_pp_opt False++mincsec_binop :: Integral t => (t -> t -> t) -> GMinCsec t -> GMinCsec t -> GMinCsec t+mincsec_binop f p q = csec_to_mincsec (f (mincsec_to_csec p) (mincsec_to_csec q))++-- * DHms++-- | Convert seconds into (days,hours,minutes,seconds).+sec_to_dhms_generic :: Integral n => n -> (n,n,n,n)+sec_to_dhms_generic n =+    let (d,h') = n `divMod` (24 * 60 * 60)+        (h,m') = h' `divMod` (60 * 60)+        (m,s) = m' `divMod` 60+    in (d,h,m,s)++-- | Type specialised 'sec_to_dhms_generic'.+--+-- > sec_to_dhms 1475469 == (17,1,51,9)+sec_to_dhms :: Sec -> Dhms+sec_to_dhms = sec_to_dhms_generic++-- | Inverse of 'seconds_to_dhms'.+--+-- > dhms_to_sec (17,1,51,9) == 1475469+dhms_to_sec :: Num n => (n,n,n,n) -> n+dhms_to_sec (d,h,m,s) = sum [d * 24 * 60 * 60,h * 60 * 60,m * 60,s]++-- | Generic form of 'parse_dhms'.+parse_dhms_generic :: (Integral n,Read n) => String -> (n,n,n,n)+parse_dhms_generic =+    let sep_elem = Split.split . Split.keepDelimsR . Split.oneOf+        sep_last x = let (e, x') = List.headTail (reverse x) in (reverse x',e)+        p x = case sep_last x of+                (n,'d') -> read n * 24 * 60 * 60+                (n,'h') -> read n * 60 * 60+                (n,'m') -> read n * 60+                (n,'s') -> read n+                _ -> error "parse_dhms"+    in sec_to_dhms_generic . sum . map p . filter (not . null) . sep_elem "dhms"++-- | Parse DHms text.  All parts are optional, order is not+-- significant, multiple entries are allowed.+--+-- > parse_dhms "17d1h51m9s" == (17,1,51,9)+-- > parse_dhms "1s3d" == (3,0,0,1)+-- > parse_dhms "1h1h" == (0,2,0,0)+parse_dhms :: String -> Dhms+parse_dhms = parse_dhms_generic++-- * Week++-- | Week that /t/ lies in.+--+-- > map (time_to_week . parse_iso8601_date) ["2017-01-01","2011-10-09"] == [52,40]+time_to_week :: Time.UTCTime -> Week+time_to_week = read . format_time_str "%V"++-- * Util++-- | Given printer, pretty print time span.+span_pp :: (t -> String) -> (t,t) -> String+span_pp f (t1,t2) = concat [f t1," - ",f t2]

@@ -0,0 +1,49 @@+-- | Traversable functions.+module Music.Theory.Traversable where++import Data.List {- base -}++-- | Replace elements at 'Traversable' with result of joining with elements from list.+--+-- > let t = Tree.Node 0 [Tree.Node 1 [Tree.Node 2 [],Tree.Node 3 []],Tree.Node 4 []]+-- > putStrLn $ Tree.drawTree (fmap show t)+-- > let (_,u) = adopt_shape (\_ x -> x) "abcde" t+-- > putStrLn $ Tree.drawTree (fmap return u)+adopt_shape :: Traversable t => (a -> b -> c) -> [b] -> t a -> ([b],t c)+adopt_shape jn l =+    let f (i:j) k = (j,jn k i)+        f [] _ = error "adopt_shape: rhs ends"+    in mapAccumL f l++-- | Two-level variant of 'adopt_shape'.+--+-- > adopt_shape_2 (,) [0..4] (words "a bc d") == ([4],[[('a',0)],[('b',1),('c',2)],[('d',3)]])+adopt_shape_2 :: (Traversable t,Traversable u) => (a -> b -> c) -> [b] -> t (u a) -> ([b],t (u c))+adopt_shape_2 jn = mapAccumL (adopt_shape jn)++{- | Adopt stream to shape of traversable and zip elements.++> adopt_shape_2_zip_stream [1..] ["a", "list", "of", "strings"]+-}+adopt_shape_2_zip_stream :: (Traversable t, Traversable u) => [c] -> t (u a) -> t (u (c, a))+adopt_shape_2_zip_stream s l = snd (adopt_shape_2 (flip (,)) s l)++-- | Two-level variant of 'zip' [1..]+--+-- > list_number_2 ["number","list","two"] == [[(1,'n'),(2,'u'),(3,'m'),(4,'b'),(5,'e'),(6,'r')],[(7,'l'),(8,'i'),(9,'s'),(10,'t')],[(11,'t'),(12,'w'),(13,'o')]]+list_number_2 :: [[x]] -> [[(Int,x)]]+list_number_2 = adopt_shape_2_zip_stream [1..]++{- | Variant of 'adopt_shape' that considers only 'Just' elements at 'Traversable'.++> let s = "a(b(cd)ef)ghi"+> let t = group_tree (begin_end_cmp_eq '(' ')') s+> adopt_shape_m (,) [1..13] t+-}+adopt_shape_m :: Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> ([b],t (Maybe c))+adopt_shape_m jn l =+    let f (i:j) k = case k of+                      Nothing -> (i:j,Nothing)+                      Just k' -> (j,Just (jn k' i))+        f [] _ = error "adopt_shape_m: rhs ends"+    in mapAccumL f l

@@ -0,0 +1,12 @@+-- | Tree functions+module Music.Theory.Tree where++import qualified Data.Tree as Tree {- containers -}++-- | Print forest as markdown list.+mdForest :: Tree.Forest String -> String+mdForest  = unlines . concatMap (mdTree 0)++-- | Print tree as markdown list with indicated starting indent level.+mdTree :: Int -> Tree.Tree String -> [String]+mdTree k (Tree.Node txt st) = (replicate (k * 2) ' ' ++ "- " ++ txt) : concatMap (mdTree (k + 1)) st

@@ -0,0 +1,403 @@+-- | 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.List {- base -}+import Data.Monoid {- base -}++-- * P2 (2-product)++p2_from_list :: (t -> t1,t -> t2) -> [t] -> (t1,t2)+p2_from_list (f1,f2) l =+  case l of+    [c1,c2] -> (f1 c1,f2 c2)+    _ -> error "p2_from_list"++-- | Swap elements of P2+--+-- > p2_swap (1,2) == (2,1)+p2_swap :: (s,t) -> (t,s)+p2_swap (i,j) = (j,i)++-- * T2 (2-tuple, regular)++-- | Uniform two-tuple.+type T2 a = (a,a)++t2_from_list :: [t] -> T2 t+t2_from_list l = case l of {[p,q] -> (p,q);_ -> error "t2_from_list"}++t2_to_list :: T2 a -> [a]+t2_to_list (i,j) = [i,j]++t2_swap :: T2 t -> T2 t+t2_swap = p2_swap++t2_map :: (p -> q) -> T2 p -> T2 q+t2_map f (p,q) = (f p,f q)++t2_zipWith :: (p -> q -> r) -> T2 p -> T2 q -> T2 r+t2_zipWith f (p,q) (p',q') = (f p p',f q q')++t2_infix :: (a -> a -> b) -> T2 a -> b+t2_infix f (i,j) = i `f` j++-- | 't2_infix' 'mappend'.+--+-- > t2_join ([1,2],[3,4]) == [1,2,3,4]+t2_join :: Data.Monoid.Monoid m => T2 m -> m+t2_join = t2_infix mappend++-- | 't2_map' 'mconcat' of 'unzip'+--+-- > t2_concat [("ab","cd"),("ef","gh")] == ("abef","cdgh")+t2_concat :: Data.Monoid.Monoid m => [T2 m] -> T2 m+t2_concat = t2_map mconcat . unzip++-- | 'sort'+--+-- > t2_sort (2,1) == (1,2)+t2_sort :: Ord t => (t,t) -> (t,t)+t2_sort (p,q) = (min p q,max p q)++-- | 'sum'+t2_sum :: Num n => (n,n) -> n+t2_sum (i,j) = i + j++-- | 'mapM'+t2_mapM :: Monad m => (t -> m u) -> (t,t) -> m (u,u)+t2_mapM f (i,j) = f i >>= \p -> f j >>= \q -> return (p,q)++-- | 'mapM_'+t2_mapM_ :: Monad m => (t -> m u) -> (t,t) -> m ()+t2_mapM_ f (i,j) = f i >> f j >> return ()++-- * P3 (3-product)++-- | Left rotation.+--+-- > p3_rotate_left (1,2,3) == (2,3,1)+p3_rotate_left :: (s,t,u) -> (t,u,s)+p3_rotate_left (i,j,k) = (j,k,i)++p3_fst :: (a,b,c) -> a+p3_fst (a,_,_) = a++p3_snd :: (a,b,c) -> b+p3_snd (_,b,_) = b++p3_third :: (a,b,c) -> c+p3_third (_,_,c) = c++-- * T3 (3 triple, regular)++type T3 a = (a,a,a)++t3_from_list :: [t] -> T3 t+t3_from_list l = case l of {[p,q,r] -> (p,q,r);_ -> error "t3_from_list"}++t3_to_list :: T3 a -> [a]+t3_to_list (i,j,k) = [i,j,k]++t3_rotate_left :: T3 t -> T3 t+t3_rotate_left = p3_rotate_left++t3_fst :: T3 t -> t+t3_fst = p3_fst++t3_snd :: T3 t -> t+t3_snd = p3_snd++t3_third :: T3 t -> t+t3_third = p3_third++t3_map :: (p -> q) -> T3 p -> T3 q+t3_map f (p,q,r) = (f p,f q,f r)++t3_zipWith :: (p -> q -> r) -> T3 p -> T3 q -> T3 r+t3_zipWith f (p,q,r) (p',q',r') = (f p p',f q q',f r r')++t3_infix :: (a -> a -> a) -> T3 a -> a+t3_infix f (i,j,k) = (i `f` j) `f` k++t3_join :: T3 [a] -> [a]+t3_join = t3_infix (++)++t3_sort :: Ord t => (t,t,t) -> (t,t,t)+t3_sort = t3_from_list . sort . t3_to_list++-- * P4 (4-product)++p4_fst :: (a,b,c,d) -> a+p4_fst (a,_,_,_) = a++p4_snd :: (a,b,c,d) -> b+p4_snd (_,b,_,_) = b++p4_third :: (a,b,c,d) -> c+p4_third (_,_,c,_) = c++p4_fourth :: (a,b,c,d) -> d+p4_fourth (_,_,_,d) = d++p4_zip :: (a,b,c,d) -> (e,f,g,h) -> ((a,e),(b,f),(c,g),(d,h))+p4_zip (a,b,c,d) (e,f,g,h) = ((a,e),(b,f),(c,g),(d,h))++-- * T4 (4-tuple, regular)++type T4 a = (a,a,a,a)++t4_from_list :: [t] -> T4 t+t4_from_list l = case l of {[p,q,r,s] -> (p,q,r,s); _ -> error "t4_from_list"}++t4_to_list :: T4 t -> [t]+t4_to_list (p,q,r,s) = [p,q,r,s]++t4_fst :: T4 t -> t+t4_fst = p4_fst++t4_snd :: T4 t -> t+t4_snd = p4_snd++t4_third :: T4 t -> t+t4_third = p4_third++t4_fourth :: T4 t -> t+t4_fourth = p4_fourth++t4_map :: (p -> q) -> T4 p -> T4 q+t4_map f (p,q,r,s) = (f p,f q,f r,f s)++t4_zipWith :: (p -> q -> r) -> T4 p -> T4 q -> T4 r+t4_zipWith f (p,q,r,s) (p',q',r',s') = (f p p',f q q',f r r',f s s')++t4_infix :: (a -> a -> a) -> T4 a -> a+t4_infix f (i,j,k,l) = ((i `f` j) `f` k) `f` l++t4_join :: T4 [a] -> [a]+t4_join = t4_infix (++)++-- * P5 (5-product)++p5_fst :: (a,b,c,d,e) -> a+p5_fst (a,_,_,_,_) = a++p5_snd :: (a,b,c,d,e) -> b+p5_snd (_,b,_,_,_) = b++p5_third :: (a,b,c,d,e) -> c+p5_third (_,_,c,_,_) = c++p5_fourth :: (a,b,c,d,e) -> d+p5_fourth (_,_,_,d,_) = d++p5_fifth :: (a,b,c,d,e) -> e+p5_fifth (_,_,_,_,e) = e++p5_from_list :: (t -> t1, t -> t2, t -> t3, t -> t4, t -> t5) -> [t] -> (t1,t2,t3,t4,t5)+p5_from_list (f1,f2,f3,f4,f5) l =+  case l of+    [c1,c2,c3,c4,c5] -> (f1 c1,f2 c2,f3 c3,f4 c4,f5 c5)+    _ -> error "p5_from_list"++p5_to_list :: (t1 -> t, t2 -> t, t3 -> t, t4 -> t, t5 -> t) -> (t1, t2, t3, t4, t5) -> [t]+p5_to_list (f1,f2,f3,f4,f5) (c1,c2,c3,c4,c5) = [f1 c1,f2 c2,f3 c3,f4 c4,f5 c5]++-- * T5 (5-tuple, regular)++type T5 a = (a,a,a,a,a)++t5_from_list :: [t] -> T5 t+t5_from_list l = case l of {[p,q,r,s,t] -> (p,q,r,s,t); _ -> error "t5_from_list"}++t5_to_list :: T5 t -> [t]+t5_to_list (p,q,r,s,t) = [p,q,r,s,t]++t5_map :: (p -> q) -> T5 p -> T5 q+t5_map f (p,q,r,s,t) = (f p,f q,f r,f s,f t)++t5_fst :: T5 t -> t+t5_fst (p,_,_,_,_) = p++t5_snd :: T5 t -> t+t5_snd (_,q,_,_,_) = q++t5_fourth :: T5 t -> t+t5_fourth (_,_,_,t,_) = t++t5_fifth :: T5 t -> t+t5_fifth (_,_,_,_,u) = u++t5_infix :: (a -> a -> a) -> T5 a -> a+t5_infix f (i,j,k,l,m) = (((i `f` j) `f` k) `f` l) `f` m++t5_join :: T5 [a] -> [a]+t5_join = t5_infix (++)++-- * P6 (6-product)++p6_fst :: (a,b,c,d,e,f) -> a+p6_fst (a,_,_,_,_,_) = a++p6_snd :: (a,b,c,d,e,f) -> b+p6_snd (_,b,_,_,_,_) = b++p6_third :: (a,b,c,d,e,f) -> c+p6_third (_,_,c,_,_,_) = c++p6_fourth :: (a,b,c,d,e,f) -> d+p6_fourth (_,_,_,d,_,_) = d++p6_fifth :: (a,b,c,d,e,f) -> e+p6_fifth (_,_,_,_,e,_) = e++p6_sixth :: (a,b,c,d,e,f) -> f+p6_sixth (_,_,_,_,_,f) = f++-- * T6 (6-tuple, regular)++type T6 a = (a,a,a,a,a,a)++t6_from_list :: [t] -> T6 t+t6_from_list l = case l of {[p,q,r,s,t,u] -> (p,q,r,s,t,u);_ -> error "t6_from_list"}++t6_to_list :: T6 t -> [t]+t6_to_list (p,q,r,s,t,u) = [p,q,r,s,t,u]++t6_map :: (p -> q) -> T6 p -> T6 q+t6_map f (p,q,r,s,t,u) = (f p,f q,f r,f s,f t,f u)++t6_sum :: Num t => T6 t -> t+t6_sum (a,b,c,d,e,f) = a + b + c + d + e + f++-- * T7 (7-tuple, regular)++type T7 a = (a,a,a,a,a,a,a)++t7_to_list :: T7 t -> [t]+t7_to_list (p,q,r,s,t,u,v) = [p,q,r,s,t,u,v]++t7_map :: (p -> q) -> T7 p -> T7 q+t7_map f (p,q,r,s,t,u,v) = (f p,f q,f r,f s,f t,f u,f v)++-- * T8 (8-tuple, regular)++type T8 a = (a,a,a,a,a,a,a,a)++t8_to_list :: T8 t -> [t]+t8_to_list (p,q,r,s,t,u,v,w) = [p,q,r,s,t,u,v,w]++t8_map :: (p -> q) -> T8 p -> T8 q+t8_map f (p,q,r,s,t,u,v,w) = (f p,f q,f r,f s,f t,f u,f v,f w)++-- * P8 (8-product)++p8_third :: (a,b,c,d,e,f,g,h) -> c+p8_third (_,_,c,_,_,_,_,_) = c++-- * T9 (9-tuple, regular)++type T9 a = (a,a,a,a,a,a,a,a,a)++t9_to_list :: T9 t -> [t]+t9_to_list (p,q,r,s,t,u,v,w,x) = [p,q,r,s,t,u,v,w,x]++t9_from_list :: [t] -> T9 t+t9_from_list l = case l of {[p,q,r,s,t,u,v,w,x] -> (p,q,r,s,t,u,v,w,x); _ -> error "t9_from_list?"}++t9_map :: (p -> q) -> T9 p -> T9 q+t9_map f (p,q,r,s,t,u,v,w,x) = (f p,f q,f r,f s,f t,f u,f v,f w,f x)++-- * T10 (10-tuple, regular)++type T10 a = (a,a,a,a,a,a,a,a,a,a)++t10_to_list :: T10 t -> [t]+t10_to_list (p,q,r,s,t,u,v,w,x,y) = [p,q,r,s,t,u,v,w,x,y]++t10_map :: (p -> q) -> T10 p -> T10 q+t10_map f (p,q,r,s,t,u,v,w,x,y) = (f p,f q,f r,f s,f t,f u,f v,f w,f x,f y)++-- * T11 (11-tuple, regular)++type T11 a = (a,a,a,a,a,a,a,a,a,a,a)++t11_to_list :: T11 t -> [t]+t11_to_list (p,q,r,s,t,u,v,w,x,y,z) = [p,q,r,s,t,u,v,w,x,y,z]++t11_map :: (p -> q) -> T11 p -> T11 q+t11_map f (p,q,r,s,t,u,v,w,x,y,z) = (f p,f q,f r,f s,f t,f u,f v,f w,f x,f y,f z)++-- * T12 (12-tuple, regular)++type T12 t = (t,t,t,t,t,t,t,t,t,t,t,t)++t12_to_list :: T12 t -> [t]+t12_to_list (p,q,r,s,t,u,v,w,x,y,z,a) = [p,q,r,s,t,u,v,w,x,y,z,a]++t12_from_list :: [t] -> T12 t+t12_from_list l =+    case l of+      [p,q,r,s,t,u,v,w,x,y,z,a] -> (p,q,r,s,t,u,v,w,x,y,z,a)+      _ -> error "t12_from_list"++-- | 'foldr1' of 't12_to_list'.+--+-- > t12_foldr1 (+) (1,2,3,4,5,6,7,8,9,10,11,12) == 78+t12_foldr1 :: (t -> t -> t) -> T12 t -> t+t12_foldr1 f = foldr1 f . t12_to_list++-- | 'sum' of 't12_to_list'.+--+-- > t12_sum (1,2,3,4,5,6,7,8,9,10,11,12) == 78+t12_sum :: Num n => T12 n -> n+t12_sum t =+    let (n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12) = t+    in n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8 + n9 + n10 + n11 + n12++-- * Family of 'uncurry' functions.++uncurry3 :: (a->b->c -> z) -> (a,b,c) -> z+uncurry3 fn (a,b,c) = fn a b c+uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d) -> z+uncurry4 fn (a,b,c,d) = fn a b c d+uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e) -> z+uncurry5 fn (a,b,c,d,e) = fn a b c d e+uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f) -> z+uncurry6 fn (a,b,c,d,e,f) = fn a b c d e f+uncurry7 :: (a->b->c->d->e->f->g -> z) -> (a,b,c,d,e,f,g) -> z+uncurry7 fn (a,b,c,d,e,f,g) = fn a b c d e f g+uncurry8 :: (a->b->c->d->e->f->g->h -> z) -> (a,b,c,d,e,f,g,h) -> z+uncurry8 fn (a,b,c,d,e,f,g,h) = fn a b c d e f g h+uncurry9 :: (a->b->c->d->e->f->g->h->i -> z) -> (a,b,c,d,e,f,g,h,i) -> z+uncurry9 fn (a,b,c,d,e,f,g,h,i) = fn a b c d e f g h i+uncurry10 :: (a->b->c->d->e->f->g->h->i->j -> z) -> (a,b,c,d,e,f,g,h,i,j) -> z+uncurry10 fn (a,b,c,d,e,f,g,h,i,j) = fn a b c d e f g h i j+uncurry11 :: (a->b->c->d->e->f->g->h->i->j->k -> z) -> (a,b,c,d,e,f,g,h,i,j,k) -> z+uncurry11 fn (a,b,c,d,e,f,g,h,i,j,k) = fn a b c d e f g h i j k+uncurry12 :: (a->b->c->d->e->f->g->h->i->j->k->l -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l) -> z+uncurry12 fn (a,b,c,d,e,f,g,h,i,j,k,l) = fn a b c d e f g h i j k l+uncurry13 :: (a->b->c->d->e->f->g->h->i->j->k->l->m -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) -> z+uncurry13 fn (a,b,c,d,e,f,g,h,i,j,k,l,m) = fn a b c d e f g h i j k l m+uncurry14 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> z+uncurry14 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = fn a b c d e f g h i j k l m n+uncurry15 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -> z+uncurry15 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = fn a b c d e f g h i j k l m n o+uncurry16 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> z+uncurry16 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = fn a b c d e f g h i j k l m n o p+uncurry17 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) -> z+uncurry17 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = fn a b c d e f g h i j k l m n o p q+uncurry18 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) -> z+uncurry18 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = fn a b c d e f g h i j k l m n o p q r+uncurry19 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) -> z+uncurry19 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = fn a b c d e f g h i j k l m n o p q r s+uncurry20 :: (a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t -> z) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) -> z+uncurry20 fn (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = fn a b c d e f g h i j k l m n o p q r s t++-- Local Variables:+-- truncate-lines:t+-- End:

@@ -0,0 +1,509 @@+-- | <http://www.unicode.org/charts/PDF/U1D100.pdf>+--+-- These symbols are in <http://www.gnu.org/software/freefont/>,+-- debian=ttf-freefont.+module Music.Theory.Unicode where++import Data.Char {- base -}+import Data.List {- base -}+import Numeric {- base -}++import qualified Text.CSV.Lazy.String as C {- lazy-csv -}++import qualified Music.Theory.Io as T {- hmt-base -}+import qualified Music.Theory.List as T {- hmt-base -}+import qualified Music.Theory.Read as T {- hmt-base -}++-- * Non-music++-- | Unicode non breaking hypen character.+--+-- > non_breaking_hypen == '‑'+non_breaking_hypen :: Char+non_breaking_hypen = toEnum 0x2011++-- | Unicode non breaking space character.+--+-- > non_breaking_space == ' '+non_breaking_space :: Char+non_breaking_space = toEnum 0x00A0++-- | Unicode interpunct.+--+-- > middle_dot == '·'+middle_dot :: Char+middle_dot = toEnum 0x00B7++-- | The superscript variants of the digits 0-9+superscript_digits :: [Char]+superscript_digits = "⁰¹²³⁴⁵⁶⁷⁸⁹"++-- | Map 'show' of 'Int' to 'superscript_digits'.+--+-- > unwords (map int_show_superscript [0,12,345,6789]) == "⁰ ¹² ³⁴⁵ ⁶⁷⁸⁹"+int_show_superscript :: Int -> String+int_show_superscript = map ((superscript_digits !!) . digitToInt) . show++-- | The subscript variants of the digits 0-9+subscript_digits :: [Char]+subscript_digits = "₀₁₂₃₄₅₆₇₈₉"++-- | The combining over line character.+--+-- > ['1',combining_overline] == "1̅"+-- > ['A',combining_overline] == "A̅"+combining_overline :: Char+combining_overline = toEnum 0x0305++-- | Add 'combining_overline' to each 'Char'.+--+-- > overline "1234" == "1̅2̅3̅4̅"+overline :: String -> String+overline = let f x = [x,combining_overline] in concatMap f++-- | The combining under line character.+--+-- > ['1',combining_underline] == "1̲"+combining_underline :: Char+combining_underline = toEnum 0x0332++-- | Add 'combining_underline' to each 'Char'.+--+-- > underline "1234" == "1̲2̲3̲4̲"+underline :: String -> String+underline = let f x = [x,combining_underline] in concatMap f++-- * Table++type Unicode_Index = Int+type Unicode_Name = String+type Unicode_Range = (Unicode_Index,Unicode_Index)+type Unicode_Point = (Unicode_Index,Unicode_Name)+type Unicode_Table = [Unicode_Point]++{- | <http://unicode.org/Public/11.0.0/ucd/UnicodeData.txt>++> let fn = "/home/rohan/data/unicode.org/Public/11.0.0/ucd/UnicodeData.txt"+> tbl <- unicode_data_table_read fn+> length tbl == 32292+> T.reverse_lookup_err "MIDDLE DOT" tbl == 0x00B7+> putStrLn $ unwords $ map (\(n,x) -> toEnum n : x) $ filter (\(_,x) -> "EMPTY SET" `isInfixOf` x) tbl+> T.lookup_err 0x22C5 tbl == "DOT OPERATOR"+-}+unicode_data_table_read :: FilePath -> IO Unicode_Table+unicode_data_table_read fn = do+  s <- T.read_file_utf8 fn+  let t = C.fromCSVTable (C.csvTable (C.parseDSV False ';' s))+      f x = (T.read_hex_err (x !! 0),x !! 1)+  return (map f t)++unicode_table_block :: (Unicode_Index,Unicode_Index) -> Unicode_Table -> Unicode_Table+unicode_table_block (l,r) = takeWhile ((<= r) . fst) . dropWhile ((< l) . fst)++unicode_point_hs :: Unicode_Point -> String+unicode_point_hs (n,s) = concat ["(0x",showHex n "",",\"",s,"\")"]++unicode_table_hs :: Unicode_Table -> String+unicode_table_hs = T.bracket ('[',']') . intercalate "," . map unicode_point_hs++-- * Music++-- > putStrLn$ map (toEnum . fst) (concat music_tbl)+music_tbl :: [Unicode_Table]+music_tbl = [barlines_tbl,accidentals_tbl,notes_tbl,rests_tbl,clefs_tbl]++-- > putStrLn$ concatMap (unicode_table_hs . flip unicode_table_block tbl) accidentals_rng_set+accidentals_rng_set :: [Unicode_Range]+accidentals_rng_set = [(0x266D,0x266F),(0x1D12A,0x1D133)]++-- > putStrLn$ unicode_table_hs (unicode_table_block barlines_rng tbl)+barlines_rng :: Unicode_Range+barlines_rng = (0x1D100,0x1D105)++-- | UNICODE barline symbols.+--+-- > let r = "𝄀𝄁𝄂𝄃𝄄𝄅" in map (toEnum . fst) barlines_tbl == r+barlines_tbl :: Unicode_Table+barlines_tbl =+  [(0x1D100,"MUSICAL SYMBOL SINGLE BARLINE")+  ,(0x1D101,"MUSICAL SYMBOL DOUBLE BARLINE")+  ,(0x1D102,"MUSICAL SYMBOL FINAL BARLINE")+  ,(0x1D103,"MUSICAL SYMBOL REVERSE FINAL BARLINE")+  ,(0x1D104,"MUSICAL SYMBOL DASHED BARLINE")+  ,(0x1D105,"MUSICAL SYMBOL SHORT BARLINE")]++-- | UNICODE accidental symbols.+--+-- > let r = "♭♮♯𝄪𝄫𝄬𝄭𝄮𝄯𝄰𝄱𝄲𝄳" in map (toEnum . fst) accidentals_tbl == r+accidentals_tbl :: Unicode_Table+accidentals_tbl =+    [(0x266D,"MUSIC FLAT SIGN")+    ,(0x266E,"MUSIC NATURAL SIGN")+    ,(0x266F,"MUSIC SHARP SIGN")+    ,(0x1D12A,"MUSICAL SYMBOL DOUBLE SHARP")+    ,(0x1D12B,"MUSICAL SYMBOL DOUBLE FLAT")+    ,(0x1D12C,"MUSICAL SYMBOL FLAT UP")+    ,(0x1D12D,"MUSICAL SYMBOL FLAT DOWN")+    ,(0x1D12E,"MUSICAL SYMBOL NATURAL UP")+    ,(0x1D12F,"MUSICAL SYMBOL NATURAL DOWN")+    ,(0x1D130,"MUSICAL SYMBOL SHARP UP")+    ,(0x1D131,"MUSICAL SYMBOL SHARP DOWN")+    ,(0x1D132,"MUSICAL SYMBOL QUARTER TONE SHARP")+    ,(0x1D133,"MUSICAL SYMBOL QUARTER TONE FLAT")]++-- > putStrLn$ unicode_table_hs (unicode_table_block notes_rng tbl)+notes_rng :: Unicode_Range+notes_rng = (0x1D15C,0x1D164)++-- | UNICODE note duration symbols.+--+-- > let r = "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲" in map (toEnum . fst) notes_tbl == r+notes_tbl :: Unicode_Table+notes_tbl =+    [(0x1D15C,"MUSICAL SYMBOL BREVE")+    ,(0x1D15D,"MUSICAL SYMBOL WHOLE NOTE")+    ,(0x1D15E,"MUSICAL SYMBOL HALF NOTE")+    ,(0x1D15F,"MUSICAL SYMBOL QUARTER NOTE")+    ,(0x1D160,"MUSICAL SYMBOL EIGHTH NOTE")+    ,(0x1D161,"MUSICAL SYMBOL SIXTEENTH NOTE")+    ,(0x1D162,"MUSICAL SYMBOL THIRTY-SECOND NOTE")+    ,(0x1D163,"MUSICAL SYMBOL SIXTY-FOURTH NOTE")+    ,(0x1D164,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE")]++-- > putStrLn$ unicode_table_hs (unicode_table_block rests_rng tbl)+rests_rng :: Unicode_Range+rests_rng = (0x1D13B,0x1D142)++-- | UNICODE rest symbols.+--+-- > let r = "𝄻𝄼𝄽𝄾𝄿𝅀𝅁𝅂" in map (toEnum . fst) rests_tbl == r+rests_tbl :: Unicode_Table+rests_tbl =+    [(0x1D13B,"MUSICAL SYMBOL WHOLE REST")+    ,(0x1D13C,"MUSICAL SYMBOL HALF REST")+    ,(0x1D13D,"MUSICAL SYMBOL QUARTER REST")+    ,(0x1D13E,"MUSICAL SYMBOL EIGHTH REST")+    ,(0x1D13F,"MUSICAL SYMBOL SIXTEENTH REST")+    ,(0x1D140,"MUSICAL SYMBOL THIRTY-SECOND REST")+    ,(0x1D141,"MUSICAL SYMBOL SIXTY-FOURTH REST")+    ,(0x1D142,"MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH REST")]++-- | Augmentation dot.+--+-- > map toEnum [0x1D15E,0x1D16D,0x1D16D] == "𝅗𝅥𝅭𝅭"+augmentation_dot :: Unicode_Point+augmentation_dot = (0x1D16D, "MUSICAL SYMBOL COMBINING AUGMENTATION DOT")++-- > putStrLn$ unicode_table_hs (unicode_table_block clefs_rng tbl)+clefs_rng :: Unicode_Range+clefs_rng = (0x1D11E,0x1D126)++-- | UNICODE clef symbols.+--+-- > let r = "𝄞𝄟𝄠𝄡𝄢𝄣𝄤𝄥𝄦" in map (toEnum . fst) clefs_tbl == r+clefs_tbl :: Unicode_Table+clefs_tbl =+    [(0x1D11E,"MUSICAL SYMBOL G CLEF")+    ,(0x1D11F,"MUSICAL SYMBOL G CLEF OTTAVA ALTA")+    ,(0x1D120,"MUSICAL SYMBOL G CLEF OTTAVA BASSA")+    ,(0x1D121,"MUSICAL SYMBOL C CLEF")+    ,(0x1D122,"MUSICAL SYMBOL F CLEF")+    ,(0x1D123,"MUSICAL SYMBOL F CLEF OTTAVA ALTA")+    ,(0x1D124,"MUSICAL SYMBOL F CLEF OTTAVA BASSA")+    ,(0x1D125,"MUSICAL SYMBOL DRUM CLEF-1")+    ,(0x1D126,"MUSICAL SYMBOL DRUM CLEF-2")]++-- > putStrLn$ unicode_table_hs (unicode_table_block noteheads_rng tbl)+noteheads_rng :: Unicode_Range+noteheads_rng = (0x1D143,0x1D15B)++-- | UNICODE notehead symbols.+--+-- > let r = "𝅃𝅄𝅅𝅆𝅇𝅈𝅉𝅊𝅋𝅌𝅍𝅎𝅏𝅐𝅑𝅒𝅓𝅔𝅕𝅖𝅗𝅘𝅙𝅚𝅛" in map (toEnum . fst) noteheads_tbl == r+noteheads_tbl :: Unicode_Table+noteheads_tbl =+    [(0x1d143,"MUSICAL SYMBOL X NOTEHEAD")+    ,(0x1d144,"MUSICAL SYMBOL PLUS NOTEHEAD")+    ,(0x1d145,"MUSICAL SYMBOL CIRCLE X NOTEHEAD")+    ,(0x1d146,"MUSICAL SYMBOL SQUARE NOTEHEAD WHITE")+    ,(0x1d147,"MUSICAL SYMBOL SQUARE NOTEHEAD BLACK")+    ,(0x1d148,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP WHITE")+    ,(0x1d149,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP BLACK")+    ,(0x1d14a,"MUSICAL SYMBOL TRIANGLE NOTEHEAD LEFT WHITE")+    ,(0x1d14b,"MUSICAL SYMBOL TRIANGLE NOTEHEAD LEFT BLACK")+    ,(0x1d14c,"MUSICAL SYMBOL TRIANGLE NOTEHEAD RIGHT WHITE")+    ,(0x1d14d,"MUSICAL SYMBOL TRIANGLE NOTEHEAD RIGHT BLACK")+    ,(0x1d14e,"MUSICAL SYMBOL TRIANGLE NOTEHEAD DOWN WHITE")+    ,(0x1d14f,"MUSICAL SYMBOL TRIANGLE NOTEHEAD DOWN BLACK")+    ,(0x1d150,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP RIGHT WHITE")+    ,(0x1d151,"MUSICAL SYMBOL TRIANGLE NOTEHEAD UP RIGHT BLACK")+    ,(0x1d152,"MUSICAL SYMBOL MOON NOTEHEAD WHITE")+    ,(0x1d153,"MUSICAL SYMBOL MOON NOTEHEAD BLACK")+    ,(0x1d154,"MUSICAL SYMBOL TRIANGLE-ROUND NOTEHEAD DOWN WHITE")+    ,(0x1d155,"MUSICAL SYMBOL TRIANGLE-ROUND NOTEHEAD DOWN BLACK")+    ,(0x1d156,"MUSICAL SYMBOL PARENTHESIS NOTEHEAD")+    ,(0x1d157,"MUSICAL SYMBOL VOID NOTEHEAD")+    ,(0x1d158,"MUSICAL SYMBOL NOTEHEAD BLACK")+    ,(0x1d159,"MUSICAL SYMBOL NULL NOTEHEAD")+    ,(0x1d15a,"MUSICAL SYMBOL CLUSTER NOTEHEAD WHITE")+    ,(0x1d15b,"MUSICAL SYMBOL CLUSTER NOTEHEAD BLACK")]++-- > map toEnum [0x1D143,0x1D165] == "𝅃𝅥"+stem :: Unicode_Point+stem = (0x1D165, "MUSICAL SYMBOL COMBINING STEM")++-- > putStrLn$ unicode_table_hs (unicode_table_block dynamics_rng tbl)+dynamics_rng :: Unicode_Range+dynamics_rng = (0x1D18C,0x1D193)++-- > map (toEnum . fst) dynamics_tbl == "𝆌𝆍𝆎𝆏𝆐𝆑𝆒𝆓"+dynamics_tbl :: Unicode_Table+dynamics_tbl =+    [(0x1d18c,"MUSICAL SYMBOL RINFORZANDO")+    ,(0x1d18d,"MUSICAL SYMBOL SUBITO")+    ,(0x1d18e,"MUSICAL SYMBOL Z")+    ,(0x1d18f,"MUSICAL SYMBOL PIANO")+    ,(0x1d190,"MUSICAL SYMBOL MEZZO")+    ,(0x1d191,"MUSICAL SYMBOL FORTE")+    ,(0x1d192,"MUSICAL SYMBOL CRESCENDO")+    ,(0x1d193,"MUSICAL SYMBOL DECRESCENDO")]++-- > putStrLn$ unicode_table_hs (unicode_table_block articulations_rng tbl)+articulations_rng :: Unicode_Range+articulations_rng = (0x1D17B,0x1D18B)++-- > putStrLn (map (toEnum . fst) articulations_tbl :: String)+articulations_tbl :: Unicode_Table+articulations_tbl =+    [(0x1d17b,"MUSICAL SYMBOL COMBINING ACCENT")+    ,(0x1d17c,"MUSICAL SYMBOL COMBINING STACCATO")+    ,(0x1d17d,"MUSICAL SYMBOL COMBINING TENUTO")+    ,(0x1d17e,"MUSICAL SYMBOL COMBINING STACCATISSIMO")+    ,(0x1d17f,"MUSICAL SYMBOL COMBINING MARCATO")+    ,(0x1d180,"MUSICAL SYMBOL COMBINING MARCATO-STACCATO")+    ,(0x1d181,"MUSICAL SYMBOL COMBINING ACCENT-STACCATO")+    ,(0x1d182,"MUSICAL SYMBOL COMBINING LOURE")+    ,(0x1d183,"MUSICAL SYMBOL ARPEGGIATO UP")+    ,(0x1d184,"MUSICAL SYMBOL ARPEGGIATO DOWN")+    ,(0x1d185,"MUSICAL SYMBOL COMBINING DOIT")+    ,(0x1d186,"MUSICAL SYMBOL COMBINING RIP")+    ,(0x1d187,"MUSICAL SYMBOL COMBINING FLIP")+    ,(0x1d188,"MUSICAL SYMBOL COMBINING SMEAR")+    ,(0x1d189,"MUSICAL SYMBOL COMBINING BEND")+    ,(0x1d18a,"MUSICAL SYMBOL COMBINING DOUBLE TONGUE")+    ,(0x1d18b,"MUSICAL SYMBOL COMBINING TRIPLE TONGUE")]++-- * Math++ix_set_to_tbl :: Unicode_Table -> [Unicode_Index] -> Unicode_Table+ix_set_to_tbl tbl ix = zip ix (map (`T.lookup_err` tbl) ix)++-- | Unicode dot-operator.+--+-- > dot_operator == '⋅'+dot_operator :: Char+dot_operator = toEnum 0x22C5++-- | Math symbols outside of the math blocks.+--+-- > putStrLn (unicode_table_hs (ix_set_to_tbl tbl math_plain_ix))+math_plain_ix :: [Unicode_Index]+math_plain_ix = [0x00D7,0x00F7]++-- > map (toEnum . fst) math_plain_tbl == "×÷"+math_plain_tbl :: Unicode_Table+math_plain_tbl = [(0xd7,"MULTIPLICATION SIGN"),(0xf7,"DIVISION SIGN")]++-- * Blocks++type Unicode_Block = (Unicode_Range,String)++-- > putStrLn$ unicode_table_hs (concatMap (flip unicode_table_block tbl . fst) unicode_blocks)+unicode_blocks :: [Unicode_Block]+unicode_blocks =+    [((0x01B00,0x01B7F),"Balinese")+    ,((0x02200,0x022FF),"Mathematical Operators")+    ,((0x025A0,0x025FF),"Geometric Shapes")+    ,((0x027C0,0x027EF),"Miscellaneous Mathematical Symbols-A")+    ,((0x027F0,0x027FF),"Supplemental Arrows-A")+    ,((0x02800,0x028FF),"Braille Patterns")+    ,((0x02900,0x0297F),"Supplemental Arrows-B")+    ,((0x02980,0x029FF),"Miscellaneous Mathematical Symbols-B")+    ,((0x02A00,0x02AFF),"Supplemental Mathematical Operators")+    ,((0x1D000,0x1D0FF),"Byzantine Musical Symbols")+    ,((0x1D100,0x1D1FF),"Musical Symbols")+    ,((0x1D200,0x1D24F),"Ancient Greek Musical Notation")+    ]++-- * BAGUA, EIGHT TRI-GRAMS++-- | Bagua tri-grams.+--+-- > putStrLn $ unicode_table_hs (unicode_table_block (fst bagua) tbl)+bagua :: Unicode_Block+bagua = ((0x02630,0x02637),"BAGUA")++{- | Table of eight tri-grams.++HEAVEN,乾,Qián,☰,111+LAKE,兌,Duì,☱,110+FIRE,離,Lí,☲,101+THUNDER,震,Zhèn,☳,100+WIND,巽,Xùn,☴,011+WATER,坎,Kǎn,☵,010+MOUNTAIN,艮,Gèn,☶,001+EARTH,坤,Kūn,☷,000++-}+bagua_tbl :: Unicode_Table+bagua_tbl =+  [(0x2630,"TRIGRAM FOR HEAVEN")+  ,(0x2631,"TRIGRAM FOR LAKE")+  ,(0x2632,"TRIGRAM FOR FIRE")+  ,(0x2633,"TRIGRAM FOR THUNDER")+  ,(0x2634,"TRIGRAM FOR WIND")+  ,(0x2635,"TRIGRAM FOR WATER")+  ,(0x2636,"TRIGRAM FOR MOUNTAIN")+  ,(0x2637,"TRIGRAM FOR EARTH")]++-- * YIJING (I-CHING), SIXTY-FOUR HEXAGRAMS++-- | Yijing hexagrams in King Wen sequence.+--+-- > putStrLn $ unicode_table_hs (unicode_table_block (fst yijing) tbl)+yijing :: Unicode_Block+yijing = ((0x04DC0,0x04DFF),"YIJING")++{- | Yijing hexagrams in King Wen sequence.++䷀,乾,qián,111,111+䷁,坤,kūn,000,000+䷂,屯,chún,100,010+䷃,蒙,méng,010,001+䷄,需,xū,111,010+䷅,訟,sòng,010,111+䷆,師,shī,010,000+䷇,比,bǐ,000,010+䷈,小畜,xiǎo chù,111,011+䷉,履,lǚ,110,111+䷊,泰,tài,111,000+䷋,否,pǐ,000,111+䷌,同人,tóng rén,101,111+䷍,大有,dà yǒu,111,101+䷎,謙,qiān,001,000+䷏,豫,yù,000,100+䷐,隨,suí,100,110+䷑,蠱,gŭ,011,001+䷒,臨,lín,110,000+䷓,觀,guān,000,011+䷔,噬嗑,shì kè,100,101+䷕,賁,bì,101,001+䷖,剝,bō,000,001+䷗,復,fù,100,000+䷘,無妄,wú wàng,100,111+䷙,大畜,dà chù,111,001+䷚,頤,yí,100,001+䷛,大過,dà guò,011,110+䷜,坎,kǎn,010,010+䷝,離,lí,101,101+䷞,咸,xián,001,110+䷟,恆,héng,011,100+䷠,遯,dùn,001,111+䷡,大壯,dà zhuàng,111,100+䷢,晉,jìn,000,101+䷣,明夷,míng yí,101,000+䷤,家人,jiā rén,101,011+䷥,睽,kuí,110,101+䷦,蹇,jiǎn,001,010+䷧,解,xiè,010,100+䷨,損,sǔn,110,001+䷩,益,yì,100,011+䷪,夬,guài,111,110+䷫,姤,gòu,011,111+䷬,萃,cuì,000,110+䷭,升,shēng,011,000+䷮,困,kùn,010,110+䷯,井,jǐng,011,010+䷰,革,gé,101,110+䷱,鼎,dǐng,011,101+䷲,震,zhèn,100,100+䷳,艮,gèn,001,001+䷴,漸,jiàn,001,011+䷵,歸妹,guī mèi,110,100+䷶,豐,fēng,101,100+䷷,旅,lǚ,001,101+䷸,巽,xùn,011,011+䷹,兌,duì,110,110+䷺,渙,huàn,010,011+䷻,節,jié,110,010+䷼,中孚,zhōng fú,110,011+䷽,小過,xiǎo guò,001,110+䷾,既濟,jì jì,101,010+䷿,未濟,wèi jì,010,101+-}+yijing_tbl :: Unicode_Table+yijing_tbl =+  [(0x4dc0,"HEXAGRAM FOR THE CREATIVE HEAVEN")+  ,(0x4dc1,"HEXAGRAM FOR THE RECEPTIVE EARTH")+  ,(0x4dc2,"HEXAGRAM FOR DIFFICULTY AT THE BEGINNING")+  ,(0x4dc3,"HEXAGRAM FOR YOUTHFUL FOLLY")+  ,(0x4dc4,"HEXAGRAM FOR WAITING")+  ,(0x4dc5,"HEXAGRAM FOR CONFLICT")+  ,(0x4dc6,"HEXAGRAM FOR THE ARMY")+  ,(0x4dc7,"HEXAGRAM FOR HOLDING TOGETHER")+  ,(0x4dc8,"HEXAGRAM FOR SMALL TAMING")+  ,(0x4dc9,"HEXAGRAM FOR TREADING")+  ,(0x4dca,"HEXAGRAM FOR PEACE")+  ,(0x4dcb,"HEXAGRAM FOR STANDSTILL")+  ,(0x4dcc,"HEXAGRAM FOR FELLOWSHIP")+  ,(0x4dcd,"HEXAGRAM FOR GREAT POSSESSION")+  ,(0x4dce,"HEXAGRAM FOR MODESTY")+  ,(0x4dcf,"HEXAGRAM FOR ENTHUSIASM")+  ,(0x4dd0,"HEXAGRAM FOR FOLLOWING")+  ,(0x4dd1,"HEXAGRAM FOR WORK ON THE DECAYED")+  ,(0x4dd2,"HEXAGRAM FOR APPROACH")+  ,(0x4dd3,"HEXAGRAM FOR CONTEMPLATION")+  ,(0x4dd4,"HEXAGRAM FOR BITING THROUGH")+  ,(0x4dd5,"HEXAGRAM FOR GRACE")+  ,(0x4dd6,"HEXAGRAM FOR SPLITTING APART")+  ,(0x4dd7,"HEXAGRAM FOR RETURN")+  ,(0x4dd8,"HEXAGRAM FOR INNOCENCE")+  ,(0x4dd9,"HEXAGRAM FOR GREAT TAMING")+  ,(0x4dda,"HEXAGRAM FOR MOUTH CORNERS")+  ,(0x4ddb,"HEXAGRAM FOR GREAT PREPONDERANCE")+  ,(0x4ddc,"HEXAGRAM FOR THE ABYSMAL WATER")+  ,(0x4ddd,"HEXAGRAM FOR THE CLINGING FIRE")+  ,(0x4dde,"HEXAGRAM FOR INFLUENCE")+  ,(0x4ddf,"HEXAGRAM FOR DURATION")+  ,(0x4de0,"HEXAGRAM FOR RETREAT")+  ,(0x4de1,"HEXAGRAM FOR GREAT POWER")+  ,(0x4de2,"HEXAGRAM FOR PROGRESS")+  ,(0x4de3,"HEXAGRAM FOR DARKENING OF THE LIGHT")+  ,(0x4de4,"HEXAGRAM FOR THE FAMILY")+  ,(0x4de5,"HEXAGRAM FOR OPPOSITION")+  ,(0x4de6,"HEXAGRAM FOR OBSTRUCTION")+  ,(0x4de7,"HEXAGRAM FOR DELIVERANCE")+  ,(0x4de8,"HEXAGRAM FOR DECREASE")+  ,(0x4de9,"HEXAGRAM FOR INCREASE")+  ,(0x4dea,"HEXAGRAM FOR BREAKTHROUGH")+  ,(0x4deb,"HEXAGRAM FOR COMING TO MEET")+  ,(0x4dec,"HEXAGRAM FOR GATHERING TOGETHER")+  ,(0x4ded,"HEXAGRAM FOR PUSHING UPWARD")+  ,(0x4dee,"HEXAGRAM FOR OPPRESSION")+  ,(0x4def,"HEXAGRAM FOR THE WELL")+  ,(0x4df0,"HEXAGRAM FOR REVOLUTION")+  ,(0x4df1,"HEXAGRAM FOR THE CAULDRON")+  ,(0x4df2,"HEXAGRAM FOR THE AROUSING THUNDER")+  ,(0x4df3,"HEXAGRAM FOR THE KEEPING STILL MOUNTAIN")+  ,(0x4df4,"HEXAGRAM FOR DEVELOPMENT")+  ,(0x4df5,"HEXAGRAM FOR THE MARRYING MAIDEN")+  ,(0x4df6,"HEXAGRAM FOR ABUNDANCE")+  ,(0x4df7,"HEXAGRAM FOR THE WANDERER")+  ,(0x4df8,"HEXAGRAM FOR THE GENTLE WIND")+  ,(0x4df9,"HEXAGRAM FOR THE JOYOUS LAKE")+  ,(0x4dfa,"HEXAGRAM FOR DISPERSION")+  ,(0x4dfb,"HEXAGRAM FOR LIMITATION")+  ,(0x4dfc,"HEXAGRAM FOR INNER TRUTH")+  ,(0x4dfd,"HEXAGRAM FOR SMALL PREPONDERANCE")+  ,(0x4dfe,"HEXAGRAM FOR AFTER COMPLETION")+  ,(0x4dff,"HEXAGRAM FOR BEFORE COMPLETION")]