hmt 0.15 → 0.16

raw patch · 148 files changed

+14571/−3412 lines, 148 filesdep +aesondep +fgldep +modular-arithmeticdep −utf8-stringdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, fgl, modular-arithmetic, random, text

Dependencies removed: utf8-string

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Help/hmt.help.lhs +0/−175
• Music/Theory/Array.hs +90/−0
• Music/Theory/Array/CSV.hs +81/−238
• Music/Theory/Array/CSV/Midi.hs +0/−86
• Music/Theory/Array/CSV/Midi/MND.hs +203/−0
• Music/Theory/Array/Cell_Ref.hs +228/−0
• Music/Theory/Array/Direction.hs +84/−0
• Music/Theory/Array/MD.hs +41/−44
• Music/Theory/Bits.hs +38/−0
• Music/Theory/Bjorklund.hs +89/−61
• Music/Theory/Block_Design/Johnson_2007.hs +1/−1
• Music/Theory/Braille.hs +273/−0
• Music/Theory/Byte.hs +55/−0
• Music/Theory/Clef.hs +2/−2
• Music/Theory/Combinations.hs +3/−3
• Music/Theory/Contour/Polansky_1992.hs +8/−58
• Music/Theory/DB/CSV.hs +24/−0
• Music/Theory/DB/Common.hs +130/−0
• Music/Theory/DB/JSON.hs +67/−0
• Music/Theory/DB/Plain.hs +60/−0
• Music/Theory/Directory.hs +38/−0
• Music/Theory/Duration.hs +102/−77
• Music/Theory/Duration/Annotation.hs +4/−85
• Music/Theory/Duration/CT.hs +2/−2
• Music/Theory/Duration/Name/Abbreviation.hs +2/−1
• Music/Theory/Duration/RQ.hs +6/−20
• Music/Theory/Duration/Sequence/Notate.hs +20/−13
• Music/Theory/Dynamic_Mark.hs +1/−1
• Music/Theory/Enum.hs +38/−0
• Music/Theory/Function.hs +8/−1
• Music/Theory/Gamelan.hs +325/−0
• Music/Theory/Graph/Deacon_1934.hs +131/−0
• Music/Theory/Graph/Dot.hs +131/−0
• Music/Theory/Graph/FGL.hs +141/−0
• Music/Theory/Graph/Johnson_2014.hs +290/−0
• Music/Theory/IO.hs +34/−0
• Music/Theory/Instrument/Names.hs +114/−0
• Music/Theory/Interval.hs +25/−46
• Music/Theory/Interval/Barlow_1987.hs +22/−15
• Music/Theory/Key.hs +189/−17
• Music/Theory/List.hs +691/−44
• Music/Theory/Map.hs +17/−0
• Music/Theory/Math.hs +111/−2
• Music/Theory/Math/Convert.hs +1121/−0
• Music/Theory/Math/OEIS.hs +27/−0
• Music/Theory/Maybe.hs +5/−1
• Music/Theory/Meter/Barlow_1987.hs +2/−2
• Music/Theory/Metric/Polansky_1996.hs +10/−10
• Music/Theory/Monad.hs +10/−0
• Music/Theory/Ord.hs +38/−0
• Music/Theory/Parse.hs +16/−0
• Music/Theory/Permutations.hs +6/−2
• Music/Theory/Permutations/List.hs +22/−3
• Music/Theory/Permutations/Morris_1984.hs +31/−16
• Music/Theory/Pitch.hs +440/−156
• Music/Theory/Pitch/Chord.hs +159/−0
• Music/Theory/Pitch/Note.hs +125/−50
• Music/Theory/Pitch/Note/Name.hs +88/−0
• Music/Theory/Pitch/Spelling.hs +14/−70
• Music/Theory/Pitch/Spelling/Cluster.hs +164/−117
• Music/Theory/Pitch/Spelling/Key.hs +33/−0
• Music/Theory/Pitch/Spelling/Table.hs +101/−0
• Music/Theory/Random/I_Ching.hs +192/−0
• Music/Theory/Read.hs +147/−0
• Music/Theory/Set/List.hs +33/−9
• Music/Theory/Show.hs +2/−0
• Music/Theory/String.hs +15/−0
• Music/Theory/Tempo_Marking.hs +1/−1
• Music/Theory/Tiling/Canon.hs +41/−37
• Music/Theory/Time/Bel1990/R.hs +28/−204
• Music/Theory/Time/Notation.hs +89/−5
• Music/Theory/Time/Seq.hs +271/−83
• Music/Theory/Time_Signature.hs +8/−1
• Music/Theory/Tuning.hs +296/−73
• Music/Theory/Tuning/Alves.hs +0/−25
• Music/Theory/Tuning/Alves_1997.hs +8/−2
• Music/Theory/Tuning/DB.hs +62/−0
• Music/Theory/Tuning/DB/Alves.hs +26/−0
• Music/Theory/Tuning/DB/Gann.hs +130/−0
• Music/Theory/Tuning/DB/Microtonal_Synthesis.hs +230/−0
• Music/Theory/Tuning/DB/Riley.hs +22/−0
• Music/Theory/Tuning/DB/Werckmeister.hs +117/−0
• Music/Theory/Tuning/ET.hs +53/−42
• Music/Theory/Tuning/Euler.hs +138/−0
• Music/Theory/Tuning/Gann.hs +0/−141
• Music/Theory/Tuning/Gann_1993.hs +139/−0
• Music/Theory/Tuning/Load.hs +78/−0
• Music/Theory/Tuning/Meyer_1929.hs +6/−5
• Music/Theory/Tuning/Microtonal_Synthesis.hs +0/−205
• Music/Theory/Tuning/Polansky_1978.hs +40/−24
• Music/Theory/Tuning/Polansky_1984.hs +7/−11
• Music/Theory/Tuning/Riley.hs +0/−18
• Music/Theory/Tuning/Rosenboom_1979.hs +190/−0
• Music/Theory/Tuning/Scala.hs +313/−125
• Music/Theory/Tuning/Scala/Interval.hs +62/−0
• Music/Theory/Tuning/Scala/Mode.hs +117/−0
• Music/Theory/Tuning/Sethares_1994.hs +39/−0
• Music/Theory/Tuning/Werckmeister.hs +0/−105
• Music/Theory/Tuple.hs +94/−33
• Music/Theory/Unicode.hs +186/−3
• Music/Theory/Wyschnegradsky.hs +331/−0
• Music/Theory/Xenakis/S4.hs +81/−25
• Music/Theory/Xenakis/Sieve.hs +105/−0
• Music/Theory/Z.hs +103/−50
• Music/Theory/Z/Boros_1990.hs +296/−0
• Music/Theory/Z/Clough_1979.hs +116/−0
• Music/Theory/Z/Drape_1999.hs +36/−0
• Music/Theory/Z/Forte_1973.hs +381/−33
• Music/Theory/Z/Read_1978.hs +16/−13
• Music/Theory/Z/SRO.hs +149/−43
• Music/Theory/Z/TTO.hs +75/−0
• Music/Theory/Z12.hs +84/−75
• Music/Theory/Z12/Castren_1994.hs +15/−14
• Music/Theory/Z12/Drape_1999.hs +360/−114
• Music/Theory/Z12/Forte_1973.hs +31/−244
• Music/Theory/Z12/Lewin_1980.hs +2/−1
• Music/Theory/Z12/Morris_1974.hs +18/−18
• Music/Theory/Z12/Morris_1987.hs +0/−87
• Music/Theory/Z12/Morris_1987/Parse.hs +1/−37
• Music/Theory/Z12/Rahn_1980.hs +1/−1
• Music/Theory/Z12/Read_1978.hs +1/−1
• Music/Theory/Z12/SRO.hs +44/−43
• Music/Theory/Z12/TTO.hs +28/−27
• README +7/−1
• data/csv/mnd/1080-C01.csv +1801/−0
• data/dot/euler-j5-a.dot +30/−0
• data/dot/euler-j5-b.dot +30/−0
• data/dot/euler-j7.dot +29/−0
• data/dot/euler-wtp.dot +30/−0
• data/dot/tj_oh_p012.dot +30/−0
• data/dot/tj_oh_p014.dot +58/−0
• data/dot/tj_oh_p031.dot +53/−0
• data/dot/tj_oh_p125.dot +72/−0
• data/dot/tj_oh_p131.dot +26/−0
• data/dot/tj_oh_p162.dot +83/−0
• data/scl/dr_itb_etude_1.scl +41/−0
• data/scl/et12.scl +17/−0
• data/scl/et19.scl +24/−0
• data/scl/et31.scl +36/−0
• data/scl/et53.scl +58/−0
• data/scl/et72.scl +77/−0
• data/scl/et96.scl +101/−0
• data/scl/hs17.scl +22/−0
• data/scl/hs19.scl +24/−0
• data/scl/hs21.scl +26/−0
• data/scl/hs23.scl +28/−0
• data/scl/young-lm_piano_1964.scl +17/−0
• hmt.cabal +66/−14

@@ -1,175 +0,0 @@-# Pct--> import Control.Arrow {- base -}-> import Data.Function {- base -}-> import Data.List {- base -}-> import Data.Maybe {- base -}-> import Music.Theory.List {- hmt -}-> import Music.Theory.Permutations {- hmt -}-> import Music.Theory.Set.List {- hmt -}-> import Music.Theory.Z12.Drape_1999 {- hmt -}-> import Music.Theory.Z12.Forte_1973 {- hmt -}-> import Music.Theory.Z12.Morris_1987 {- hmt -}-> import Music.Theory.Z12.Morris_1987.Parse {- hmt -}-> import Music.Theory.Z12.SRO {- hmt -}--This file illustrates equivalent expressions in pct and hmt terms.--    $ pcom pcseg iseg 01549 | pcom iseg icseg | pcom icseg icset-    145--> (set . map ic . int) [0,1,5,4,9] == [1,4,5]--    $ pcom pcseg pcset 01549 | pcom pcset sc | pcom sc icv | pcom icv icset-    1345--> let icv_icset x = let f x y = if x > 0 then Just y else Nothing->                   in catMaybes (zipWith f x [1..6])-> in (icv_icset . icv . forte_prime) [0,1,5,4,9] == [1,3,4,5]--    $ pg 5-Z17 | bip | sort -u > 5-Z17.bip ; \-      pg 5-Z37 | bip | sort -u > 5-Z37.bip ; \-      comm 5-Z17.bip 5-Z37.bip -1 -2 | wc -l-    16--> let f = nub . map bip . permutations . sc-> in length (f "5-Z17" `intersect` f "5-Z37") == 16--    $ cat ../db.sh-    for sc in $(fl -c $1)-    do-      pg $sc | bip | sort -u > $sc-    done-    $ sh ../db.sh 4-    $ ls-    4-1   4-12  4-16  4-19  4-21  4-24  4-27  4-4   4-7   4-Z15-    4-10  4-13  4-17  4-2   4-22  4-25  4-28  4-5   4-8   4-Z29-    4-11  4-14  4-18  4-20  4-23  4-26  4-3   4-6   4-9--> let {s = filter ((== 4) . length) scs->     ;x = map permutations s}-> in zip (map sc_name s) (map (set . (map bip)) x)--    $ cat view.sh-    for i in $(fl -c $1 | pg | bip | sort -u)-    do-      echo $i":" $(grep -l $i * | sort -t '-' +1  -n | tr "\n" " ")-    done-    $ sh view.sh 4-    111: 4-1-    112: 4-1 4-2 4-3-    113: 4-1 4-3 4-4 4-7-    ...--> let {n = 4->     ;s = filter ((== n) . length) scs->     ;x = map permutations s->     ;z = zip (map sc_name s) (map (set . (map bip)) x)->     ;f b (s,bs) = if b `elem` bs then Just s else Nothing->     ;g b = catMaybes (map (f b) z)->     ;a = set (map bip (concat x))}-> in zip a (map g a)--    $ cyc <  ~/src/pct/lib/scs | epmq \-    > "in cset 89" "is icset 12" "hasnt icseg 11" | scdb-    7-34    ascending melodic minor collection-    7-35    diatonic collection (d)-    8-28    octotonic collection (Messiaen Mode II)--> let {cyc xs = xs ++ [head xs]->     ;a = filter (\p -> length p `elem` [8,9]) (map cyc scs)->     ;b = filter (\p -> set (int p) == [1,2]) a->     ;c = filter (\p -> not ([1,1] `isInfixOf` int p)) b}-> in map (sc_name . nub) c == ["7-34","7-35","8-28"]--    $ epmq < ~/src/pct/lib/univ "in cset 6" "in pcset 579t024" \-    > "has sc 5-35" "hasnt sc 2-6" "notin pcset 024579e"-    02579A--> let {a = cf [6] (powerset [0..11])->     ;b = filter (is_superset [0,2,4,5,7,9,10]) a->     ;c = filter (`has_sc` (sc "5-35")) b->     ;d = filter (not . (`has_sc` (sc "2-6"))) c->     ;e = filter (not . is_superset [0,2,4,5,7,9,11]) d}-> in e == [[0,2,5,7,9,10]]--    $ echo 156 | sro T0I | sro T4-    3BA--> let {i = SRO 0 False 0 False True->     ;t4 = SRO 0 False 4 False False}-> in (sro i >>> sro t4) [1,5,6] == [3,11,10]--    $ echo 156 | sro T4  | sro T0I-    732--> let {i = SRO 0 False 0 False True->     ;t4 = SRO 0 False 4 False False}-> in (sro i . sro t4) [1,5,6] == [7,3,2]--Note that pct uses right rotation rotation.--> sro (SRO 1 True 1 True False) [0,1,2,3] == [11,6,1,4]-> sro (SRO 1 False 4 True True) [0,1,2,3] == [11,6,1,4]--    I = MB; TnI = TnMB,--> mn 11 [0,1,4,9] == tni 0 [0,1,4,9]--    MI = IM = M7 = MBM5; TnMI = TnM7--> sro (rnrtnmi "T0MI") [0,1,4,9] == mn 7 [0,1,4,9]--    T0 = T0M1; Tn = TnM1-    M = M5; TnM = TnM5,--    $ se -c5 123-    12333-    12233-    12223-    11233-    11223-    11123--> expand_set 5 [1,2,3]--> ici [1,2,3]-> cgg [[0],[1,11],[2,10],[3,9],[4,8],[5,7],[6]]--    $ se -c5 1245 | pg | ici | pcom iseg sc | \-      sort -u | epmq "in cset 6" | wc -l-    42--> let {a = expand_set 5 [1,2,4,5]->     ;b = concatMap permutations a->     ;c = concatMap ici b->     ;d = map (forte_prime . dx_d 0) c->     ;e = nub d->     ;f = cf [6] e}-> in length f == 42--    $ imb -c34 024579 | pfmt-    024 245 457 579-    0245 2457 4579--> imb [3,4] [0,2,4,5,7,9]--    $ rs 0123 e614-    T1M-    $ rs 0123 641e416-    T1M--    $ sb 6-32 6-8 | fn | pfmt-    1-1-    2-1 2-2 2-3 2-4 2-5-    3-2 3-4 3-6 3-7 3-9 3-11-    4-10 4-11 4-14 4-22 4-23-    5-23-    $ for i in `cat ~/src/pct/lib/scs | cf 6 | fn` ; \-      do echo $i >> LIST ; sb $i | cf 3 | wc -l >> LIST ; done--> map sc_name (sb [sc "6-32",sc "6-8"])--> let f p = let xs = cf [3] (sb [p])->           in (sc_name p,length xs)-> in map f (cf [6] scs)

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

@@ -1,228 +1,25 @@ -- | Regular matrix array data, CSV, column & row indexing. module Music.Theory.Array.CSV where -import Data.Array {- array -}-import Data.Char {- base -}-import Data.Function {- base -}+import qualified Data.Array as A {- array -} import Data.List {- base -}-import Data.String {- base -}  import qualified Text.CSV.Lazy.String as C {- lazy-csv -} +import qualified Music.Theory.Array.Cell_Ref as T {- hmt -}+import qualified Music.Theory.IO as T {- hmt -} import qualified Music.Theory.List as T {- hmt -}---- * Indexing---- | @A@ indexed case-insensitive column references.  The column--- following @Z@ is @AA@.-data Column_Ref = Column_Ref {column_ref_string :: String}--instance IsString Column_Ref where fromString = Column_Ref-instance Read Column_Ref where readsPrec _ s = [(Column_Ref s,[])]-instance Show Column_Ref where show = column_ref_string-instance Eq Column_Ref where (==) = (==) `on` column_index-instance Ord Column_Ref where compare = compare `on` column_index--instance Enum Column_Ref where-    fromEnum = column_index-    toEnum = column_ref--instance Ix Column_Ref where-    range = column_range-    index = interior_column_index-    inRange = column_in_range-    rangeSize = column_range_size---- | Inclusive range of column references.-type Column_Range = (Column_Ref,Column_Ref)---- | @1@-indexed row reference.-type Row_Ref = Int---- | Zero index of 'Row_Ref'.-row_index :: Row_Ref -> Int-row_index r = r - 1---- | Inclusive range of row references.-type Row_Range = (Row_Ref,Row_Ref)---- | Cell reference, column then row.-type Cell_Ref = (Column_Ref,Row_Ref)---- | Inclusive range of cell references.-type Cell_Range = (Cell_Ref,Cell_Ref)---- | Case folding letter to index function.  Only valid for ASCII letters.------ > map letter_index ['A' .. 'Z'] == [0 .. 25]--- > map letter_index ['a','d' .. 'm'] == [0,3 .. 12]-letter_index :: Char -> Int-letter_index c = fromEnum (toUpper c) - fromEnum 'A'---- | Inverse of 'letter_index'.------ > map index_letter [0,3 .. 12] == ['A','D' .. 'M']-index_letter :: Int -> Char-index_letter i = toEnum (i + fromEnum 'A')---- | Translate column reference to @0@-index.------ > :set -XOverloadedStrings--- > map column_index ["A","c","z","ac","XYZ"] == [0,2,25,28,17575]-column_index :: Column_Ref -> Int-column_index (Column_Ref c) =-    let m = iterate (* 26) 1-        i = reverse (map letter_index c)-    in sum (zipWith (*) m (zipWith (+) [0..] i))---- | Column reference to interior index within specified range.  Type--- specialised 'Data.Ix.index'.------ > map (Data.Ix.index ('A','Z')) ['A','C','Z'] == [0,2,25]--- > map (interior_column_index ("A","Z")) ["A","C","Z"] == [0,2,25]------ > map (Data.Ix.index ('B','C')) ['B','C'] == [0,1]--- > map (interior_column_index ("B","C")) ["B","C"] == [0,1]-interior_column_index :: Column_Range -> Column_Ref -> Int-interior_column_index (l,r) c =-    let n = column_index c-        l' = column_index l-        r' = column_index r-    in if n > r'-       then error (show ("interior_column_index",l,r,c))-       else n - l'---- | Inverse of 'column_index'.------ > let c = ["A","Z","AA","AZ","BA","BZ","CA"]--- > in map column_ref [0,25,26,51,52,77,78] == c------ > column_ref (0+25+1+25+1+25+1) == "CA"-column_ref :: Int -> Column_Ref-column_ref =-    let rec n = case n `quotRem` 26 of-                  (0,r) -> [index_letter r]-                  (q,r) -> index_letter (q - 1) : rec r-    in Column_Ref . rec---- | Type specialised 'pred'.------ > column_ref_pred "DF" == "DE"-column_ref_pred :: Column_Ref -> Column_Ref-column_ref_pred = pred---- | Type specialised 'succ'.------ > column_ref_succ "DE" == "DF"-column_ref_succ :: Column_Ref -> Column_Ref-column_ref_succ = succ---- | Bimap of 'column_index'.------ > column_indices ("b","p") == (1,15)--- > column_indices ("B","IT") == (1,253)-column_indices :: Column_Range -> (Int,Int)-column_indices =-    let bimap f (i,j) = (f i,f j)-    in bimap column_index---- | Type specialised 'Data.Ix.range'.------ > column_range ("L","R") == ["L","M","N","O","P","Q","R"]--- > Data.Ix.range ('L','R') == "LMNOPQR"-column_range :: Column_Range -> [Column_Ref]-column_range rng =-    let (l,r) = column_indices rng-    in map column_ref [l .. r]---- | Type specialised 'Data.Ix.inRange'.------ > map (column_in_range ("L","R")) ["A","N","Z"] == [False,True,False]--- > map (column_in_range ("L","R")) ["L","N","R"] == [True,True,True]------ > map (Data.Ix.inRange ('L','R')) ['A','N','Z'] == [False,True,False]--- > map (Data.Ix.inRange ('L','R')) ['L','N','R'] == [True,True,True]-column_in_range :: Column_Range -> Column_Ref -> Bool-column_in_range rng c =-    let (l,r) = column_indices rng-        k = column_index c-    in k >= l && k <= r---- | Type specialised 'Data.Ix.rangeSize'.------ > map column_range_size [("A","Z"),("AA","ZZ")] == [26,26 * 26]--- > Data.Ix.rangeSize ('A','Z') == 26-column_range_size :: Column_Range -> Int-column_range_size = (+ 1) . negate . uncurry (-) . column_indices---- | Type specialised 'Data.Ix.range'.-row_range :: Row_Range -> [Row_Ref]-row_range = range---- | The standard uppermost leftmost cell reference, @A1@.------ > Just cell_ref_minima == parse_cell_ref "A1"-cell_ref_minima :: Cell_Ref-cell_ref_minima = (Column_Ref "A",1)---- | Cell reference parser for standard notation of (column,row).------ > parse_cell_ref "CC348" == Just ("CC",348)-parse_cell_ref :: String -> Maybe Cell_Ref-parse_cell_ref s =-    case span isUpper s of-      ([],_) -> Nothing-      (c,r) -> case span isDigit r of-                 (n,[]) -> Just (Column_Ref c,read n)-                 _ -> Nothing---- | Cell reference pretty printer.------ > cell_ref_pp ("CC",348) == "CC348"-cell_ref_pp :: Cell_Ref -> String-cell_ref_pp (Column_Ref c,r) = c ++ show r---- | Translate cell reference to @0@-indexed pair.------ > cell_index ("CC",348) == (80,347)--- > Data.Ix.index (("AA",1),("ZZ",999)) ("CC",348) == 54293-cell_index :: Cell_Ref -> (Int,Int)-cell_index (c,r) = (column_index c,row_index r)---- | Type specialised 'Data.Ix.range', cells are in column-order.------ > cell_range (("AA",1),("AC",1)) == [("AA",1),("AB",1),("AC",1)]------ > let r = [("AA",1),("AA",2),("AB",1),("AB",2),("AC",1),("AC",2)]--- > in cell_range (("AA",1),("AC",2)) == r------ > Data.Ix.range (('A',1),('C',1)) == [('A',1),('B',1),('C',1)]------ > let r = [('A',1),('A',2),('B',1),('B',2),('C',1),('C',2)]--- > in Data.Ix.range (('A',1),('C',2)) == r-cell_range :: Cell_Range -> [Cell_Ref]-cell_range ((c1,r1),(c2,r2)) =-    [(c,r) |-     c <- column_range (c1,c2)-    ,r <- row_range (r1,r2)]---- | Variant of 'cell_range' in row-order.------ > let r = [(AA,1),(AB,1),(AC,1),(AA,2),(AB,2),(AC,2)]--- > in cell_range_row_order (("AA",1),("AC",2)) == r-cell_range_row_order ::  Cell_Range -> [Cell_Ref]-cell_range_row_order ((c1,r1),(c2,r2)) =-    [(c,r) |-     r <- row_range (r1,r2)-    ,c <- column_range (c1,c2)]+import qualified Music.Theory.Tuple as T {- hmt -}  -- * 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,@@ -242,26 +39,28 @@ -- columns. type Table a = [[a]] --- | CSV table, ie. a table with perhaps a header.+-- | CSV table, ie. a 'Table' with 'Maybe' a header. type CSV_Table a = (Maybe [String],Table a) --- | Read 'Table' from @CSV@ file.+-- | 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 <- readFile fn+  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 'Table' only with 'def_csv_opt'.-csv_table_read' :: (String -> a) -> FilePath -> IO (Table a)-csv_table_read' f = fmap snd . csv_table_read def_csv_opt f+csv_table_read_def :: (String -> a) -> FilePath -> IO (Table a)+csv_table_read_def f = fmap snd . csv_table_read def_csv_opt f --- | Read and process @CSV@ 'Table'.+-- | 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 -> Table String -> Table String csv_table_align align tbl =@@ -274,40 +73,43 @@                        CSV_Align_Right -> s ++ pd     in transpose (zipWith (map . ext) n c) --- | Write 'Table' to @CSV@ file.+-- | 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 (_,delim,brk,align) fn (hdr,tbl) = do-  let tbl' = csv_table_align align (map (map f) tbl)-      (_,t) = C.toCSVTable (T.mcons hdr tbl')-      s = C.ppDSVTable brk delim t-  writeFile fn s+csv_table_write f opt fn csv = T.write_file_utf8 fn (csv_table_pp f opt csv) --- | Write 'Table' only (no header).-csv_table_write' :: (a -> String) -> CSV_Opt -> FilePath -> Table a -> IO ()-csv_table_write' f opt fn tbl = csv_table_write f opt fn (Nothing,tbl)+-- | Write 'Table' only (no header) with 'def_csv_opt'.+csv_table_write_def :: (a -> String) -> FilePath -> Table a -> IO ()+csv_table_write_def f fn tbl = csv_table_write f def_csv_opt fn (Nothing,tbl)  -- | @0@-indexed (row,column) cell lookup. table_lookup :: Table a -> (Int,Int) -> a table_lookup t (r,c) = (t !! r) !! c  -- | Row data.-table_row :: Table a -> Row_Ref -> [a]-table_row t r = t !! row_index r+table_row :: Table a -> T.Row_Ref -> [a]+table_row t r = t !! T.row_index r  -- | Column data.-table_column :: Table a -> Column_Ref -> [a]-table_column t c = transpose t !! column_index c+table_column :: Table a -> T.Column_Ref -> [a]+table_column t c = transpose t !! T.column_index c  -- | Lookup value across columns.-table_column_lookup :: Eq a => Table a -> (Column_Ref,Column_Ref) -> a -> Maybe a+table_column_lookup :: Eq a => Table a -> (T.Column_Ref,T.Column_Ref) -> a -> Maybe a table_column_lookup t (c1,c2) e =     let a = zip (table_column t c1) (table_column t c2)     in lookup e a  -- | Table cell lookup.-table_cell :: Table a -> Cell_Ref -> a+table_cell :: Table a -> T.Cell_Ref -> a table_cell t (c,r) =-    let (r',c') = (row_index r,column_index c)+    let (r',c') = (T.row_index r,T.column_index c)     in table_lookup t (r',c')  -- | @0@-indexed (row,column) cell lookup over column range.@@ -317,9 +119,9 @@     in take (c1 - c0 + 1) (drop c0 r')  -- | Range of cells from row.-table_row_segment :: Table a -> (Row_Ref,Column_Range) -> [a]+table_row_segment :: Table a -> (T.Row_Ref,T.Column_Range) -> [a] table_row_segment t (r,c) =-    let (r',c') = (row_index r,column_indices c)+    let (r',c') = (T.row_index r,T.column_indices c)     in table_lookup_row_segment t (r',c')  -- * Array@@ -333,14 +135,55 @@ -- > > (((A,1),(C,2)) -- > > ,[(A,1),(A,2),(B,1),(B,2),(C,1),(C,2)] -- > > ,[0,2,1,4,3,5])-table_to_array :: Table a -> Array Cell_Ref a+table_to_array :: Table a -> A.Array T.Cell_Ref a table_to_array t =     let nr = length t         nc = length (t !! 0)-        bnd = (cell_ref_minima,(toEnum (nc - 1),nr))-        asc = zip (cell_range_row_order bnd) (concat t)-    in array bnd asc+        bnd = (T.cell_ref_minima,(toEnum (nc - 1),nr))+        asc = zip (T.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 (Array Cell_Ref a)+csv_array_read :: CSV_Opt -> (String -> a) -> FilePath -> IO (A.Array T.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))++-- * Tuples++type P5_Parser t1 t2 t3 t4 t5 = (String -> t1,String -> t2,String -> t3,String -> t4,String -> t5)+type P5_Writer t1 t2 t3 t4 t5 = (t1 -> String,t2 -> String,t3 -> String,t4 -> String,t5 -> String)++csv_table_read_p5 :: P5_Parser t1 t2 t3 t4 t5 -> CSV_Opt -> FilePath -> IO (Maybe [String],[(t1,t2,t3,t4,t5)])+csv_table_read_p5 f opt fn = do+  (hdr,dat) <- csv_table_read opt id fn+  return (hdr,map (T.p5_from_list f) dat)++csv_table_write_p5 :: P5_Writer t1 t2 t3 t4 t5 -> CSV_Opt -> FilePath -> (Maybe [String],[(t1,t2,t3,t4,t5)]) -> IO ()+csv_table_write_p5 f opt fn (hdr,dat) = csv_table_write id opt fn (hdr,map (T.p5_to_list f) dat)

@@ -1,86 +0,0 @@--- | Functions for reading midi note data from CSV files.-module Music.Theory.Array.CSV.Midi where--import Data.Function {- base -}-import Data.Maybe {- base -}--import qualified Music.Theory.Array.CSV as T {- hmt -}-import qualified Music.Theory.Time.Seq as T {- hmt -}---- | Variant of 'reads' requiring exact match.-reads_exact :: Read a => String -> Maybe a-reads_exact s =-    case reads s of-      [(r,"")] -> Just r-      _ -> Nothing---- | Variant of 'reads_exact' that errors on failure.-reads_err :: Read a => String -> a-reads_err str = fromMaybe (error ("could not read: " ++ str)) (reads_exact str)---- | The required header field.-csv_midi_note_data_hdr :: [String]-csv_midi_note_data_hdr = ["time","on/off","note","velocity"]---- | Midi note data, header is @time,on/off,note,velocity@.--- Translation values for on/off are consulted.------ > let fn = "/home/rohan/cvs/uc/uc-26/daily-practice/2014-08-13.1.csv"--- > csv_midi_note_data_read' ("ON","OFF") fn :: IO [(Double,Either String String,Double,Double)]-csv_midi_note_data_read' :: (Read t,Real t,Read n,Real n) => (m,m) -> FilePath -> IO [(t,Either m String,n,n)]-csv_midi_note_data_read' (m_on,m_off) =-    let err x = error ("csv_midi_note_data_read: " ++ x)-        read_md x = case x of-                      "on" -> Left m_on-                      "off" -> Left m_off-                      _ -> Right x-        f m =-            case m of-              [st,md,mnn,amp] -> (reads_err st,read_md md,reads_err mnn,reads_err amp)-              _ -> err "entry?"-        g (hdr,dat) = case hdr of-                        Just hdr' -> if hdr' == csv_midi_note_data_hdr then dat else err "header?"-                        Nothing -> err "no header?"-    in fmap (map f . g) . T.csv_table_read (True,',',False,T.CSV_No_Align) id---- | Variant of 'csv_midi_note_data_read'' that errors on non on/off data.-csv_midi_note_data_read :: (Read t,Real t,Read n,Real n) => (m,m) -> FilePath -> IO [(t,m,n,n)]-csv_midi_note_data_read m =-    let f (t,p,q,r) = (t,either id (error "not on/off") p,q,r)-    in fmap (map f) . csv_midi_note_data_read' m---- | 'Tseq' form of 'csv_read_midi_note_data'.-midi_tseq_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.On_Off (n,n)))-midi_tseq_read =-    let mk_node (st,md,mnn,amp) = if md-                                  then (st,T.On (mnn,amp))-                                  else (st,T.Off (mnn,0))-    in fmap (map mk_node) . csv_midi_note_data_read (True,False)---- | Translate from 'Tseq' form to 'Wseq' form.-midi_tseq_to_midi_wseq :: (Num t,Eq n) => T.Tseq t (T.On_Off (n,n)) -> T.Wseq t (n,n)-midi_tseq_to_midi_wseq = T.tseq_on_off_to_wseq ((==) `on` fst)---- | Off-velocity is zero.-midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t (n,n) -> T.Tseq t (T.On_Off (n,n))-midi_wseq_to_midi_tseq = T.wseq_on_off---- | Writer.-csv_midi_note_data_write :: (Eq m,Show t,Real t,Show n,Real n) => (m,m) -> FilePath -> [(t,m,n,n)] -> IO ()-csv_midi_note_data_write (m_on,m_off) nm =-    let show_md md = if md == m_on-                     then "on" else if md == m_off-                                    then "off"-                                    else error "csv_midi_note_data_write"-        un_node (st,md,mnn,amp) = [show st,show_md md,show mnn,show amp]-        with_hdr dat = (Just csv_midi_note_data_hdr,dat)-    in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node---- | 'Tseq' form of 'csv_midi_note_data_write'.-midi_tseq_write :: (Show t,Real t,Show n,Real n) => FilePath -> T.Tseq t (T.On_Off (n,n)) -> IO ()-midi_tseq_write nm sq =-    let f (t,e) = case e of-                    T.On (n,v) -> (t,True,n,v)-                    T.Off (n,v) -> (t,False,n,v)-        sq' = map f sq-    in csv_midi_note_data_write (True,False) nm sq'

@@ -0,0 +1,203 @@+-- | Functions for reading midi note data (MND) from CSV files.+-- This is /not/ a generic text midi notation.+-- The defined commands are @on@ and @off@, but others may be present.+-- Non-integral note number and key velocity data are allowed.+module Music.Theory.Array.CSV.Midi.MND where++import Data.List.Split {- split -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Word {- base -}++import qualified Music.Theory.Array.CSV as T {- hmt -}+import qualified Music.Theory.Math as T {- hmt -}+import qualified Music.Theory.Read as T {- hmt -}+import qualified Music.Theory.Time.Seq as T {- hmt -}++-- | If /r/ is whole to /k/ places then show as integer, else as float to /k/ places.+data_value_pp :: Real t => Int -> t -> String+data_value_pp k r =+    if T.whole_to_precision k r+    then show (T.real_floor_int r)+    else T.real_pp k r++-- | Channel values are 4-bit (0-15).+type Channel = Word8++-- | The required header field.+csv_mnd_hdr :: [String]+csv_mnd_hdr = ["time","on/off","note","velocity","channel","param"]++type Param = (String,Double)++param_parse :: String -> [Param]+param_parse str =+    let f x = case splitOn "=" x of+                [lhs,rhs] -> (lhs,read rhs)+                _ -> error ("param_parse: " ++ x)+    in if null str then [] else map f (splitOn ";" str)++param_pp :: Int -> [Param] -> String+param_pp k =+    let f (lhs,rhs) = concat [lhs,"=",T.real_pp k rhs]+    in intercalate ";" . map f++-- | Midi note data, the type parameters are to allow for fractional note & velocity values.+-- The command is a string, @on@ and @off@ are standard, other commands may be present.+--+-- > unwords csv_mnd_hdr == "time on/off note velocity channel param"+type MND t n = (t,String,n,n,Channel,[Param])++csv_mnd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MND t n]+csv_mnd_parse (hdr,dat) =+    let err x = error ("csv_mnd_read: " ++ x)+        f m = case m of+                [st,msg,mnn,vel,ch,pm] ->+                    (T.reads_exact_err "time:real" st+                    ,msg+                    ,T.reads_exact_err "note:real" mnn+                    ,T.reads_exact_err "velocity:real" vel+                    ,T.reads_exact_err "channel:int" ch+                    ,param_parse pm)+                _ -> err "entry?"+    in case hdr of+         Just hdr' -> if hdr' == csv_mnd_hdr then map f dat else err "header?"+         Nothing -> err "no header?"++load_csv :: FilePath -> IO (T.CSV_Table String)+load_csv = T.csv_table_read (True,',',False,T.CSV_No_Align) id++-- | Midi note data.+--+-- > let fn = "/home/rohan/cvs/uc/uc-26/daily-practice/2014-08-13.1.csv"+-- > m <- csv_mnd_read fn :: IO [MND Double Double]+-- > length m == 17655+-- > csv_mnd_write 4 "/tmp/t.csv" m+csv_mnd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MND t n]+csv_mnd_read = fmap csv_mnd_parse . load_csv++-- | Writer.+csv_mnd_write :: (Real t,Real n) => Int -> FilePath -> [MND t n] -> IO ()+csv_mnd_write r_prec nm =+    let un_node (st,msg,mnn,vel,ch,pm) =+            [T.real_pp r_prec st+            ,msg+            ,data_value_pp r_prec mnn+            ,data_value_pp r_prec vel+            ,show ch+            ,param_pp r_prec pm]+        with_hdr dat = (Just csv_mnd_hdr,dat)+    in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node++-- * MND Seq forms++-- | (p0=midi-note,p1=velocity,channel,param)+type Event n = (n,n,Channel,[Param])++-- | Translate from 'Tseq' form to 'Wseq' form.+midi_tseq_to_midi_wseq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (Event n)) -> T.Wseq t (Event n)+midi_tseq_to_midi_wseq = T.tseq_begin_end_to_wseq (\(n0,_,c0,_) (n1,_,c1,_) -> c0 == c1 && n0 == n1)++midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t x -> T.Tseq t (T.Begin_End x)+midi_wseq_to_midi_tseq = T.wseq_begin_end++-- | Ignores non on/off messages.+mnd_to_tseq :: Num n => [MND t n] -> T.Tseq t (T.Begin_End (Event n))+mnd_to_tseq =+    let mk_node (st,msg,mnn,vel,ch,pm) =+            case msg of+              "on" -> Just (st,T.Begin (mnn,vel,ch,pm))+              "off" -> Just (st,T.End (mnn,0,ch,pm))+              _ -> Nothing+    in mapMaybe mk_node++-- | 'Tseq' form of 'csv_mnd_read', channel information is retained, off-velocity is zero.+csv_mnd_read_tseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.Begin_End (Event n)))+csv_mnd_read_tseq = fmap mnd_to_tseq . csv_mnd_read++-- | 'Tseq' form of 'csv_mnd_write', data is .+csv_mnd_write_tseq :: (Real t,Real n) => Int -> FilePath -> T.Tseq t (T.Begin_End (Event n)) -> IO ()+csv_mnd_write_tseq r_prec nm sq =+    let f (t,e) = case e of+                    T.Begin (n,v,c,p) -> (t,"on",n,v,c,p)+                    T.End (n,_,c,p) -> (t,"off",n,0,c,p)+    in csv_mnd_write r_prec nm (map f sq)++-- * MNDD (simplifies cases where overlaps on the same channel are allowed).++-- | Message should be @note@ for note data.+csv_mndd_hdr :: [String]+csv_mndd_hdr = ["time","duration","message","note","velocity","channel","param"]++-- > unwords csv_mndd_hdr == "time duration message note velocity channel param"+type MNDD t n = (t,t,String,n,n,Channel,[Param])++csv_mndd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MNDD t n]+csv_mndd_parse (hdr,dat) =+    let err x = error ("csv_mndd_read: " ++ x)+        f m =+            case m of+              [st,du,msg,mnn,vel,ch,pm] ->+                  (T.reads_exact_err "time" st+                  ,T.reads_exact_err "duration" du+                  ,msg+                  ,T.reads_exact_err "note" mnn+                  ,T.reads_exact_err "velocity" vel+                  ,T.reads_exact_err "channel" ch+                  ,param_parse pm)+              _ -> err "entry?"+    in case hdr of+         Just hdr' -> if hdr' == csv_mndd_hdr then map f dat else err "header?"+         Nothing -> err "no header?"++-- | Midi note/duration data.+csv_mndd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MNDD t n]+csv_mndd_read = fmap csv_mndd_parse . load_csv++-- | Writer.+csv_mndd_write :: (Real t,Real n) => Int -> FilePath -> [MNDD t n] -> IO ()+csv_mndd_write r_prec nm =+    let un_node (st,du,msg,mnn,vel,ch,pm) =+            [T.real_pp r_prec st,T.real_pp r_prec du,msg+            ,data_value_pp r_prec mnn,data_value_pp r_prec vel+            ,show ch+            ,param_pp r_prec pm]+        with_hdr dat = (Just csv_mndd_hdr,dat)+    in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node++-- * MNDD Seq forms++-- | Ignores non note messages.+mndd_to_wseq :: [MNDD t n] -> T.Wseq t (Event n)+mndd_to_wseq =+    let mk_node (st,du,msg,mnn,vel,ch,pm) =+            case msg of+              "note" -> Just ((st,du),(mnn,vel,ch,pm))+              _ -> Nothing+    in mapMaybe mk_node++-- | 'Wseq' form of 'csv_mndd_read'.+csv_mndd_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))+csv_mndd_read_wseq = fmap mndd_to_wseq . csv_mndd_read++-- | 'Wseq' form of 'csv_mndd_write'.+csv_mndd_write_wseq :: (Real t,Real n) => Int -> FilePath -> T.Wseq t (Event n) -> IO ()+csv_mndd_write_wseq r_prec nm =+    let f ((st,du),(mnn,vel,ch,pm)) = (st,du,"note",mnn,vel,ch,pm)+    in csv_mndd_write r_prec nm . map f++-- * Composite++-- | Parse either MND or MNDD data to Wseq, CSV type is decided by header.+csv_midi_parse_wseq :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> T.Wseq t (Event n)+csv_midi_parse_wseq (hdr,dat) = do+  case hdr of+    Just hdr' -> if hdr' == csv_mnd_hdr+                 then midi_tseq_to_midi_wseq (mnd_to_tseq (csv_mnd_parse (hdr,dat)))+                 else if hdr' == csv_mndd_hdr+                      then mndd_to_wseq (csv_mndd_parse (hdr,dat))+                      else error "csv_midi_read_wseq: not MND or MNDD"+    _ -> error "csv_midi_read_wseq: header?"++csv_midi_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))+csv_midi_read_wseq = fmap csv_midi_parse_wseq . load_csv

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

@@ -0,0 +1,84 @@+-- | Directions in an array.+module Music.Theory.Array.Direction where++import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Music.Theory.Array.Cell_Ref as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}++-- * LOC / VEC++-- | (column,row)+type LOC n = (n,n)++-- | (Δcolumn,Δrow), rows /descend/, ie. down is positive, up is negative.+type VEC n = (n,n)++vector_add :: Num n => VEC n -> VEC n -> VEC n+vector_add (c1,r1) (c2,r2) = (c1 + c2,r1 + r2)++vector_sub :: Num n => VEC n -> VEC n -> VEC n+vector_sub (c1,r1) (c2,r2) = (c1 - c2,r1 - r2)++vector_sum :: Num n => [VEC n] -> VEC n+vector_sum = foldl1 vector_add++apply_vec :: Num n => LOC n -> VEC n -> LOC n+apply_vec (c,r) (dc,dr) = (c + dc,r + dr)++-- | Segment 'VEC' into a sequence of unit steps.+--+-- > let r = [[(0,0)],[(0,1)],[(0,1),(-1,0)],[(0,1),(0,1),(0,1),(-1,0),(-1,0)]]+-- > in map segment_vec [(0,0),(0,1),(-1,1),(-2,3)] == r+segment_vec :: Integral n => VEC n -> [VEC n]+segment_vec v =+    case v of+      (0,0) -> [v]+      (c,r) -> genericReplicate (abs r) (0,signum r) ++ genericReplicate (abs c) (signum c,0)++derive_vec :: Num n => LOC n -> LOC n -> VEC n+derive_vec (c1,r1) (c2,r2) = (c2 - c1,r2 - r1)++unfold_path :: Num n => LOC n -> [VEC n] -> [LOC n]+unfold_path l p = scanl apply_vec l p++-- * DIRECTION (non-diagonal)++type DIRECTION_S = String++-- | Directions are D=down, L=left, R=right, U=up.+is_direction :: String -> Bool+is_direction = (`elem` "DLRU.") . head++type DIRECTION_C = Char++-- | Reads either S|D W|L E|R N|U, reverse lookup gives SWEN. A period+-- indicates (0,0). S=south, W=west, E=east, N=north.+direction_char_to_vector_tbl :: Num n => [(DIRECTION_C,VEC n)]+direction_char_to_vector_tbl =+    [('.',(0,0))+    ,('S',(0,1)),('W',(-1,0)),('E',(1,0)),('N',(0,-1))+    ,('D',(0,1)),('L',(-1,0)),('R',(1,0)),('U',(0,-1))]++-- > map direction_char_to_vector "LU"+direction_char_to_vector :: Num n => DIRECTION_C -> VEC n+direction_char_to_vector d = fromMaybe (error "dir?") $ lookup d direction_char_to_vector_tbl++-- > let r = [(0,-1),(0,1),(-1,0),(1,0),(-1,-1),(1,1),(-2,0),(-1,-1)]+-- > in map direction_to_vector (words "U D L R UL DR LL LU") == r+direction_to_vector :: Num n => [DIRECTION_C] -> VEC n+direction_to_vector = vector_sum . map direction_char_to_vector++vector_to_direction_char :: (Eq n, Num n) => VEC n -> DIRECTION_C+vector_to_direction_char v =+    let r = T.reverse_lookup v direction_char_to_vector_tbl+    in fromMaybe (error "vec->dir?") r++-- | Direction sequence to cell references.+dir_seq_to_cell_seq :: (String,[String]) -> [String]+dir_seq_to_cell_seq (l,v) =+    let p = map direction_to_vector v+        c = T.parse_cell_index l+    in map (T.cell_ref_pp . T.index_to_cell) (unfold_path c p)+

@@ -1,25 +1,11 @@ -- | Regular array data as markdown (MD) tables. module Music.Theory.Array.MD where -import Data.Char {- base -} import Data.List {- base -} +import qualified Music.Theory.Array as T {- hmt -} import qualified Music.Theory.List as T {- hmt -}---- | Append /k/ to the right of /l/ until result has /n/ places.-pad_right :: a -> Int -> [a] -> [a]-pad_right k n l = take n (l ++ repeat k)---- | Append /k/ to each row of /tbl/ as required to be regular (all--- rows equal length).-make_regular :: a -> [[a]] -> [[a]]-make_regular k tbl =-    let z = maximum (map length tbl)-    in map (pad_right k z) tbl---- | Delete trailing 'Char' where 'isSpace' holds.-delete_trailing_whitespace :: [Char] -> [Char]-delete_trailing_whitespace = reverse . dropWhile isSpace . reverse+import qualified Music.Theory.String as T {- hmt -}  -- | Optional header row then data rows. type MD_Table t = (Maybe [String],[[t]])@@ -39,19 +25,21 @@     in (hdr',tbl')  -- | Markdown table, perhaps with header.  Table is in row order.--- Options are: /pad_left/.+-- Options are /pad_left/ and /eq_width/. ----- > md_table_opt False (Nothing,[["a","bc","def"],["ghij","klm","no","p"]])-md_table_opt :: Bool -> MD_Table String -> [String]-md_table_opt pleft (hdr,t) =-    let t' = maybe t (:t) hdr-        c = transpose (make_regular "" t')-        n = map (maximum . map length) c-        ext k s = let pd = replicate (k - length s) ' '-                  in if pleft then pd ++ s else s ++ pd-        m = unwords (map (flip replicate '-') n)-        w = map unwords (transpose (zipWith (map . ext) n c))-        d = map delete_trailing_whitespace w+-- > let tbl = [["a","bc","def"],["ghij","klm","no","p"]]+-- > putStrLn$unlines$"": md_table_opt (True,True," · ") (Nothing,tbl)+md_table_opt :: (Bool,Bool,String) -> MD_Table String -> [String]+md_table_opt (pad_left,eq_width,col_sep) (hdr,t) =+    let c = transpose (T.make_regular "" (maybe t (:t) hdr))+        nc = length c+        n = let k = map (maximum . map length) c+            in if eq_width then replicate nc (maximum k) else k+        ext k s = if pad_left then T.pad_left ' ' k s else T.pad_right ' ' k s+        jn = intercalate col_sep+        m = jn (map (flip replicate '-') n)+        w = map jn (transpose (zipWith (map . ext) n c))+        d = map T.delete_trailing_whitespace w     in case hdr of          Nothing -> T.bracket (m,m) d          Just _ -> case d of@@ -59,7 +47,7 @@                      d0:d' -> d0 : T.bracket (m,m) d'  md_table' :: MD_Table String -> [String]-md_table' = md_table_opt True+md_table' = md_table_opt (True,False," ")  -- | 'curry' of 'md_table''. md_table :: Maybe [String] -> [[String]] -> [String]@@ -88,24 +76,33 @@ {- | Matrix form, ie. header in both first row and first column, in each case displaced by one location which is empty. -> let t = md_matrix "" (map return "abc") (map (map show) [[1,2,3],[2,3,1],[3,1,2]])+> let h = (map return "abc",map return "efgh")+> let t = md_matrix "" h (map (map show) [[1,2,3,4],[2,3,4,1],[3,4,1,2]])  >>> putStrLn $ unlines $ md_table' t-- - - --  a b c-a 1 2 3-b 2 3 1-c 3 1 2-- - - -+- - - - -+  e f g h+a 1 2 3 4+b 2 3 4 1+c 3 4 1 2+- - - - -  -}-md_matrix :: a -> [a] -> [[a]] -> MD_Table a-md_matrix nil nm t = md_table_join (Nothing,[nil] : map return nm) (Nothing,nm : t)+md_matrix :: a -> ([a],[a]) -> [[a]] -> MD_Table a+md_matrix nil (r,c) t = md_table_join (Nothing,[nil] : map return r) (Nothing,c : t) --- | Variant for 'String' tables where /nil/ is the empty string and+-- | Variant that takes a 'show' function and a /header decoration/ function.+md_matrix_opt :: (a -> String) -> (String -> String) -> ([a],[a]) -> [[a]] -> MD_Table String+md_matrix_opt show_f hd_f nm t =+    let t' = map (map show_f) t+        nm' = T.bimap1 (map (hd_f . show_f)) nm+    in md_matrix "" nm' t'++-- | MD embolden function.+md_embolden :: String -> String+md_embolden x = "__" ++ x ++ "__"++-- | 'md_matrix_opt' with 'show' and markdown /bold/ annotations for header. -- the header cells are in bold.-md_matrix_bold :: [String] -> [[String]] -> MD_Table String-md_matrix_bold nm t =-    let bold x = "__" ++ x ++ "__"-        nm' = map bold nm-    in md_matrix "" nm' t+md_matrix_bold :: Show a => ([a],[a]) -> [[a]] -> MD_Table String+md_matrix_bold = md_matrix_opt show md_embolden

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

@@ -3,10 +3,12 @@ -- /Journal of Computational Geometry: Theory and Applications/ -- Volume 42, Issue 5, July, 2009 -- (<http://dx.doi.org/10.1016/j.comgeo.2008.04.005>)-module Music.Theory.Bjorklund (bjorklund,xdot,iseq,iseq_str) where+module Music.Theory.Bjorklund where  import Data.List.Split {- split -} +import qualified Music.Theory.List as T+ type STEP a = ((Int,Int),([[a]],[[a]]))  left :: STEP a -> STEP a@@ -26,63 +28,58 @@        then (n,x)        else bjorklund' (if i > j then left (n,x) else right (n,x)) --- | Bjorklund's algorithm to construct a binary sequence of /n/ bits--- with /k/ ones such that the /k/ ones are distributed as evenly as--- possible among the (/n/ - /k/) zeroes.------ > bjorklund (5,9) == [True,False,True,False,True,False,True,False,True]--- > xdot (bjorklund (5,9)) == "x.x.x.x.x"------ > let es = [(2,3),(2,5)--- >          ,(3,4),(3,5),(3,8)--- >          ,(4,7),(4,9),(4,12),(4,15)--- >          ,(5,6),(5,7),(5,8),(5,9),(5,11),(5,12),(5,13),(5,16)--- >          ,(6,7),(6,13)--- >          ,(7,8),(7,9),(7,10),(7,12),(7,15),(7,16),(7,17),(7,18)--- >          ,(8,17),(8,19)--- >          ,(9,14),(9,16),(9,22),(9,23)--- >          ,(11,12),(11,24)--- >          ,(13,24)--- >          ,(15,34)]--- > in map (\e -> let e' = bjorklund e in (e,xdot e',iseq_str e')) es------ > [((2,3),"xx.","(12)")--- > ,((2,5),"x.x..","(23)")--- > ,((3,4),"xxx.","(112)")--- > ,((3,5),"x.x.x","(221)")--- > ,((3,8),"x..x..x.","(332)")--- > ,((4,7),"x.x.x.x","(2221)")--- > ,((4,9),"x.x.x.x..","(2223)")--- > ,((4,12),"x..x..x..x..","(3333)")--- > ,((4,15),"x...x...x...x..","(4443)")--- > ,((5,6),"xxxxx.","(11112)")--- > ,((5,7),"x.xx.xx","(21211)")--- > ,((5,8),"x.xx.xx.","(21212)")--- > ,((5,9),"x.x.x.x.x","(22221)")--- > ,((5,11),"x.x.x.x.x..","(22223)")--- > ,((5,12),"x..x.x..x.x.","(32322)")--- > ,((5,13),"x..x.x..x.x..","(32323)")--- > ,((5,16),"x..x..x..x..x...","(33334)")--- > ,((6,7),"xxxxxx.","(111112)")--- > ,((6,13),"x.x.x.x.x.x..","(222223)")--- > ,((7,8),"xxxxxxx.","(1111112)")--- > ,((7,9),"x.xxx.xxx","(2112111)")--- > ,((7,10),"x.xx.xx.xx","(2121211)")--- > ,((7,12),"x.xx.x.xx.x.","(2122122)")--- > ,((7,15),"x.x.x.x.x.x.x..","(2222223)")--- > ,((7,16),"x..x.x.x..x.x.x.","(3223222)")--- > ,((7,17),"x..x.x..x.x..x.x.","(3232322)")--- > ,((7,18),"x..x.x..x.x..x.x..","(3232323)")--- > ,((8,17),"x.x.x.x.x.x.x.x..","(22222223)")--- > ,((8,19),"x..x.x.x..x.x.x..x.","(32232232)")--- > ,((9,14),"x.xx.xx.xx.xx.","(212121212)")--- > ,((9,16),"x.xx.x.x.xx.x.x.","(212221222)")--- > ,((9,22),"x..x.x..x.x..x.x..x.x.","(323232322)")--- > ,((9,23),"x..x.x..x.x..x.x..x.x..","(323232323)")--- > ,((11,12),"xxxxxxxxxxx.","(11111111112)")--- > ,((11,24),"x..x.x.x.x.x..x.x.x.x.x.","(32222322222)")--- > ,((13,24),"x.xx.x.x.x.x.xx.x.x.x.x.","(2122222122222)")--- > ,((15,34),"x..x.x.x.x..x.x.x.x..x.x.x.x..x.x.","(322232223222322)")]+{- | Bjorklund's algorithm to construct a binary sequence of /n/ bits+with /k/ ones such that the /k/ ones are distributed as evenly as+possible among the (/n/ - /k/) zeroes.++> bjorklund (5,9) == [True,False,True,False,True,False,True,False,True]+> map xdot (bjorklund (5,9)) == "x.x.x.x.x"++> let {es = [(2,[3,5]),(3,[4,5,8]),(4,[7,9,12,15]),(5,[6,7,8,9,11,12,13,16])+>           ,(6,[7,13]),(7,[8,9,10,12,15,16,17,18]),(8,[17,19])+>           ,(9,[14,16,22,23]),(11,[12,24]),(13,[24]),(15,[34])]+>     ;es' = concatMap (\(i,j) -> map ((,) i) j) es}+> in mapM_ (putStrLn . euler_pp') es'++> > E(2,3) [××·] (12)+> > E(2,5) [×·×··] (23)+> > E(3,4) [×××·] (112)+> > E(3,5) [×·×·×] (221)+> > E(3,8) [×··×··×·] (332)+> > E(4,7) [×·×·×·×] (2221)+> > E(4,9) [×·×·×·×··] (2223)+> > E(4,12) [×··×··×··×··] (3333)+> > E(4,15) [×···×···×···×··] (4443)+> > E(5,6) [×××××·] (11112)+> > E(5,7) [×·××·××] (21211)+> > E(5,8) [×·××·××·] (21212)+> > E(5,9) [×·×·×·×·×] (22221)+> > E(5,11) [×·×·×·×·×··] (22223)+> > E(5,12) [×··×·×··×·×·] (32322)+> > E(5,13) [×··×·×··×·×··] (32323)+> > E(5,16) [×··×··×··×··×···] (33334)+> > E(6,7) [××××××·] (111112)+> > E(6,13) [×·×·×·×·×·×··] (222223)+> > E(7,8) [×××××××·] (1111112)+> > E(7,9) [×·×××·×××] (2112111)+> > E(7,10) [×·××·××·××] (2121211)+> > E(7,12) [×·××·×·××·×·] (2122122)+> > E(7,15) [×·×·×·×·×·×·×··] (2222223)+> > E(7,16) [×··×·×·×··×·×·×·] (3223222)+> > E(7,17) [×··×·×··×·×··×·×·] (3232322)+> > E(7,18) [×··×·×··×·×··×·×··] (3232323)+> > E(8,17) [×·×·×·×·×·×·×·×··] (22222223)+> > E(8,19) [×··×·×·×··×·×·×··×·] (32232232)+> > E(9,14) [×·××·××·××·××·] (212121212)+> > E(9,16) [×·××·×·×·××·×·×·] (212221222)+> > E(9,22) [×··×·×··×·×··×·×··×·×·] (323232322)+> > E(9,23) [×··×·×··×·×··×·×··×·×··] (323232323)+> > E(11,12) [×××××××××××·] (11111111112)+> > E(11,24) [×··×·×·×·×·×··×·×·×·×·×·] (32222322222)+> > E(13,24) [×·××·×·×·×·×·××·×·×·×·×·] (2122222122222)+> > E(15,34) [×··×·×·×·×··×·×·×·×··×·×·×·×··×·×·] (322232223222322)++-} bjorklund :: (Int,Int) -> [Bool] bjorklund (i,j') =     let j = j' - i@@ -91,11 +88,42 @@         (_,(x',y')) = bjorklund' ((i,j),(x,y))     in concat x' ++ concat y' +-- | 'T.rotate_right' of 'bjorklund'.+--+-- > map xdot' (bjorklund_r 2 (5,16)) == "··×··×··×··×··×·"+bjorklund_r :: Int -> (Int, Int) -> [Bool]+bjorklund_r n = T.rotate_right n . bjorklund++-- | Pretty printer, generalise.+euler_pp_f :: (Bool -> Char) -> (Int,Int) -> String+euler_pp_f f e =+    let r = bjorklund e+    in concat ["E",show e," [",map f r,"] ",iseq_str r]++-- | Unicode form, ie. @×·@.+--+-- > euler_pp' (7,12) == "E(7,12) [×·××·×·××·×·] (2122122)"+euler_pp' :: (Int, Int) -> String+euler_pp' = euler_pp_f xdot'++-- | ASCII form, ie. @x.@.+--+-- > euler_pp (7,12) == "E(7,12) [x.xx.x.xx.x.] (2122122)"+euler_pp :: (Int, Int) -> String+euler_pp = euler_pp_f xdot+ -- | /xdot/ notation for pattern. ----- > xdot (bjorklund (5,9)) == "x.x.x.x.x"-xdot :: [Bool] -> String-xdot = map (\x -> if x then 'x' else '.')+-- > map xdot (bjorklund (5,9)) == "x.x.x.x.x"+xdot :: Bool -> Char+xdot x = if x then 'x' else '.'++-- | Unicode variant.+--+-- > map xdot' (bjorklund (5,12)) == "×··×·×··×·×·"+-- > map xdot' (bjorklund (5,16)) == "×··×··×··×··×···"+xdot' :: Bool -> Char+xdot' x = if x then '×' else '·'  -- | The 'iseq' of a pattern is the distance between 'True' values. --

@@ -2,7 +2,7 @@ -- Computation in Music, Berlin, May 2007. module Music.Theory.Block_Design.Johnson_2007 where -import Control.Arrow {- base -}+import Control.Arrow ((***)) {- base -} import Data.List {- base -}  import qualified Music.Theory.List as T

@@ -0,0 +1,273 @@+-- | <http://en.wikipedia.org/wiki/Braille_Patterns>+module Music.Theory.Braille where++import Data.Char {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Text.Printf {- base -}++-- | Braille coding data.  Elements are: (ASCII HEX,ASCII CHAR,DOT+-- LIST,UNICODE CHAR,MEANING).  The dot numbers are in column order.+type BRAILLE = (Int,Char,[Int],Char,String)++-- | ASCII 'Char' of 'BRAILLE'.+braille_ascii :: BRAILLE -> Char+braille_ascii (_,c,_,_,_) = c++-- | Unicode 'Char' of 'BRAILLE'.+braille_unicode :: BRAILLE -> Char+braille_unicode (_,_,_,c,_) = c++-- | Dot list of 'BRAILLE'.+braille_dots :: BRAILLE -> [Int]+braille_dots (_,_,d,_,_) = d++-- | ASCII Braille table.+--+-- > all id (map (\(x,c,_,_,_) -> x == fromEnum c) braille_table) == True+braille_table :: [BRAILLE]+braille_table =+    [(0x20,' ',[],'⠀'," ")+    ,(0x21,'!',[2,3,4,6],'⠮',"the")+    ,(0x22,'"',[5],'⠐',"contraction")+    ,(0x23,'#',[3,4,5,6],'⠼',"number prefix")+    ,(0x24,'$',[1,2,4,6],'⠫',"ed")+    ,(0x25,'%',[1,4,6],'⠩',"sh")+    ,(0x26,'&',[1,2,3,4,6],'⠯',"and")+    ,(0x27,'\'',[3],'⠄',"'")+    ,(0x28,'(',[1,2,3,5,6],'⠷',"of")+    ,(0x29,')',[2,3,4,5,6],'⠾',"with")+    ,(0x2A,'*',[1,6],'⠡',"ch")+    ,(0x2B,'+',[3,4,6],'⠬',"ing")+    ,(0x2C,',',[6],'⠠',"uppercase prefix")+    ,(0x2D,'-',[3,6],'⠤',"-")+    ,(0x2E,'.',[4,6],'⠨',"italic prefix")+    ,(0x2F,'/',[3,4],'⠌',"st")+    ,(0x30,'0',[3,5,6],'⠴',"”")+    ,(0x31,'1',[2],'⠂',",")+    ,(0x32,'2',[2,3],'⠆',";")+    ,(0x33,'3',[2,5],'⠒',":")+    ,(0x34,'4',[2,5,6],'⠲',".")+    ,(0x35,'5',[2,6],'⠢',"en")+    ,(0x36,'6',[2,3,5],'⠖',"!")+    ,(0x37,'7',[2,3,5,6],'⠶',"( or )")+    ,(0x38,'8',[2,3,6],'⠦',"“ or ?")+    ,(0x39,'9',[3,5],'⠔',"in")+    ,(0x3A,':',[1,5,6],'⠱',"wh")+    ,(0x3B,';',[5,6],'⠰',"letter prefix")+    ,(0x3C,'<',[1,2,6],'⠣',"gh")+    ,(0x3D,'=',[1,2,3,4,5,6],'⠿',"for")+    ,(0x3E,'>',[3,4,5],'⠜',"ar")+    ,(0x3F,'?',[1,4,5,6],'⠹',"th")+    ,(0x40,'@',[4],'⠈',"accent prefix")+    ,(0x41,'A',[1],'⠁',"a")+    ,(0x42,'B',[1,2],'⠃',"b")+    ,(0x43,'C',[1,4],'⠉',"c")+    ,(0x44,'D',[1,4,5],'⠙',"d")+    ,(0x45,'E',[1,5],'⠑',"e")+    ,(0x46,'F',[1,2,4],'⠋',"f")+    ,(0x47,'G',[1,2,4,5],'⠛',"g")+    ,(0x48,'H',[1,2,5],'⠓',"h")+    ,(0x49,'I',[2,4],'⠊',"i")+    ,(0x4A,'J',[2,4,5],'⠚',"j")+    ,(0x4B,'K',[1,3],'⠅',"k")+    ,(0x4C,'L',[1,2,3],'⠇',"l")+    ,(0x4D,'M',[1,3,4],'⠍',"m")+    ,(0x4E,'N',[1,3,4,5],'⠝',"n")+    ,(0x4F,'O',[1,3,5],'⠕',"o")+    ,(0x50,'P',[1,2,3,4],'⠏',"p")+    ,(0x51,'Q',[1,2,3,4,5],'⠟',"q")+    ,(0x52,'R',[1,2,3,5],'⠗',"r")+    ,(0x53,'S',[2,3,4],'⠎',"s")+    ,(0x54,'T',[2,3,4,5],'⠞',"t")+    ,(0x55,'U',[1,3,6],'⠥',"u")+    ,(0x56,'V',[1,2,3,6],'⠧',"v")+    ,(0x57,'W',[2,4,5,6],'⠺',"w")+    ,(0x58,'X',[1,3,4,6],'⠭',"x")+    ,(0x59,'Y',[1,3,4,5,6],'⠽',"y")+    ,(0x5A,'Z',[1,3,5,6],'⠵',"z")+    ,(0x5B,'[',[2,4,6],'⠪',"ow")+    ,(0x5C,'\\',[1,2,5,6],'⠳',"ou")+    ,(0x5D,']',[1,2,4,5,6],'⠻',"er")+    ,(0x5E,'^',[4,5],'⠘',"currency prefix")+    ,(0x5F,'_',[4,5,6],'⠸',"contraction")+    ]++-- | Lookup 'BRAILLE' value for unicode character.+--+-- > braille_lookup_unicode '⠝' == Just (0x4E,'N',[1,3,4,5],'⠝',"n")+braille_lookup_unicode :: Char -> Maybe BRAILLE+braille_lookup_unicode c = find ((== c) . braille_unicode) braille_table++-- | Lookup 'BRAILLE' value for ascii character (case invariant).+--+-- > braille_lookup_ascii 'N' == Just (0x4E,'N',[1,3,4,5],'⠝',"n")+braille_lookup_ascii :: Char -> Maybe BRAILLE+braille_lookup_ascii c = find ((== (toUpper c)) . braille_ascii) braille_table++-- | The arrangement of the 6-dot patterns into /decades/, sequences+-- of (1,10,3) cells.  The cell to the left of the decade is the empty+-- cell, the two cells to the right are the first two cells of the+-- decade shifted right.+--+-- For each decade there are two extra cells that shift+-- the first two cells of the decade right one place.  Subsequent+-- decades are derived by simple transformation of the first.  The+-- second is the first with the addition of dot @3@, the third adds+-- dots @3@ and @6@, the fourth adds dot @6@ and the fifth shifts the+-- first down one row.+--+-- The first decade has the 13 of the 16 4-dot patterns, the remaining+-- 3 are in the fifth decade, that is they are the three 4-dot+-- patterns that are down shifts of a 4-dot pattern.+--+-- > let trimap f (p,q,r) = (f p,f q,f r)+-- > let f = map (fromJust . decode) in map (trimap f) braille_64+braille_64 :: [(String,String,String)]+braille_64 =+    [("⠀","⠁⠃⠉⠙⠑⠋⠛⠓⠊⠚","⠈⠘")+    ,("⠄","⠅⠇⠍⠝⠕⠏⠟⠗⠎⠞","⠌⠜")+    ,("⠤","⠥⠧⠭⠽⠵⠯⠿⠷⠮⠾","⠬⠼")+    ,("⠠","⠡⠣⠩⠹⠱⠫⠻⠳⠪⠺","⠨⠸")+    ,("","⠂⠆⠒⠲⠢⠖⠶⠦⠔⠴","⠐⠰")]++-- | Transcribe ASCII to unicode braille.+--+-- > transcribe_unicode "BRAILLE ASCII CHAR GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠁⠎⠉⠊⠊⠀⠉⠓⠁⠗⠀⠛⠗⠊⠙"+-- > transcribe_unicode "BRAILLE HTML TABLE GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠓⠞⠍⠇⠀⠞⠁⠃⠇⠑⠀⠛⠗⠊⠙"+transcribe_unicode :: String -> String+transcribe_unicode = map (braille_unicode . fromJust . braille_lookup_ascii)++-- | Generate a character grid using inidicated values for filled and empty cells.+--+-- > let ch = (' ','.')+-- > putStrLn$ transcribe_char_grid ch "BRAILLE ASCII CHAR GRID"+--+-- > let ch = (white_circle,black_circle)+-- > putStrLn$ string_html_table $ transcribe_char_grid ch "BRAILLE HTML TABLE GRID"+transcribe_char_grid :: (Char,Char) -> String -> String+transcribe_char_grid (w,b) =+    unlines .+    map concat .+    transpose .+    map (dots_grid (w,b) . braille_dots . fromJust . braille_lookup_ascii)++-- | Generate 6-dot grid given (white,black) values.+--+-- > dots_grid (0,1) [1,2,3,5] == [[1,0],[1,1],[1,0]]+dots_grid :: (c,c) -> [Int] -> [[c]]+dots_grid (w,b) d =+    let f n = if n `elem` d then b else w+    in map (map f) [[1,4],[2,5],[3,6]]++string_html_table :: String -> String+string_html_table s =+    let f x = "<td>" ++ [x] ++ "</td>"+        g x = "<tr>" ++ concatMap f x ++ "</tr>"+        h x = "<table>" ++ concatMap g x ++ "</table>"+    in h (lines s)++{- | Decoding.++> let t0 = ["⠠⠁⠇⠇⠀⠓⠥⠍⠁⠝⠀⠆⠬⠎⠀⠜⠑⠀⠃⠕⠗⠝⠀⠋⠗⠑⠑⠀⠯⠀⠑⠟⠥⠁⠇⠀⠔⠀⠙⠊⠛⠝⠰⠽⠀⠯⠀⠐⠗⠎⠲"+>          ,"⠠⠮⠽⠀⠜⠑⠀⠢⠙⠪⠫⠀⠾⠀⠗⠂⠎⠕⠝⠀⠯⠀⠒⠎⠉⠊⠰⠑⠀⠯⠀⠩⠙⠀⠁⠉⠞⠀⠞⠪⠜⠙⠎⠀⠐⠕⠀⠁⠝⠕⠤"+>          ,"⠮⠗⠀⠔⠀⠁⠀⠸⠎⠀⠷⠀⠃⠗⠕⠮⠗⠓⠕⠕⠙⠲"]++> concatMap (fromMaybe "#" . decode) (concat t0)++-}+decode :: Char -> Maybe String+decode c =+    case braille_lookup_unicode c of+      Just (_,_,_,_,s) -> Just s+      Nothing -> Nothing++-- | Start and end unicode indices.+braille_rng :: Integral i => (i,i)+braille_rng = (0x2800,0x28FF)++-- | All characters, in sequence.+--+-- > length braille_seq == 256+-- > putStrLn braille_seq+braille_seq :: [Char]+braille_seq = let (l,r) = braille_rng in [toEnum l .. toEnum r]++-- | The /n/th character, zero indexed.+braille_char :: Int -> Char+braille_char = toEnum . (+) 0x2800++-- | Two element index, 255 * 255 = 65025 places.+--+-- > map braille_ix [100,300]+braille_ix :: Int -> (Char,Char)+braille_ix n =+    let (i,j) = n `divMod` 255+        f k = braille_char (k + 1)+    in (f i,f j)++-- | HTML character encoding (as hex integer).+--+-- > unwords $ map unicode_html braille_seq+unicode_html :: Char -> String+unicode_html = printf "&#x%x;" . fromEnum++-- * Unicode++-- | White (empty) circle.+white_circle :: Char+white_circle = '○'++-- | Black (filled) circle.+black_circle :: Char+black_circle = '●'++-- | Shaded (hatched) circle.+shaded_circle :: Char+shaded_circle = '◍'++-- * Contractions++-- | Table of one letter contractions.+one_letter_contractions :: [(Char,String)]+one_letter_contractions =+    [('⠃',"but")+    ,('⠉',"can")+    ,('⠙',"do")+    ,('⠑',"every")+    ,('⠋',"from,-self")+    ,('⠛',"go")+    ,('⠓',"have")+    ,('⠚',"just")+    ,('⠅',"knowledge")+    ,('⠇',"like")+    ,('⠍',"more")+    ,('⠝',"not")+    ,('⠏',"people")+    ,('⠟',"quite")+    ,('⠗',"rather")+    ,('⠎',"so")+    ,('⠞',"that")+    ,('⠌',"still")+    ,('⠥',"us")+    ,('⠧',"very")+    ,('⠭',"it")+    ,('⠽',"you")+    ,('⠵',"as")+    ,('⠡',"child")+    ,('⠩',"shall")+    ,('⠹',"this")+    ,('⠱',"which")+    ,('⠳',"out")+    ,('⠺',"will")+    ,('⠆',"be,be-")+    ,('⠒',"con-")+    ,('⠲',"dis-")+    ,('⠢',"enough")+    ,('⠖',"to")+    ,('⠶',"were")+    ,('⠦',"his")+    ,('⠔',"in")+    ,('⠴',"by,was")+    ,('⠤',"com-")+    ]

@@ -0,0 +1,55 @@+-- | Byte functions.+module Music.Theory.Byte where++import qualified Data.ByteString as B {- bytestring -}+import Data.Char {- base -}+import Data.List.Split {- split -}+import Data.Maybe {- base -}+import Numeric {- base -}++import qualified Music.Theory.Read as T {- hmt -}++-- | 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++-- | 'unwords' of 'map' of 'byte_hex_pp_err'.+--+-- > byte_seq_hex_pp [0x0F,0xF0] == "0F F0"+byte_seq_hex_pp :: (Integral i, Show i) => [i] -> String+byte_seq_hex_pp = unwords . map byte_hex_pp_err++-- | Read two character hexadecimal string.+read_hex_byte :: (Eq t,Num t) => String -> t+read_hex_byte s =+    case s of+      [_,_] -> T.reads_to_read_precise_err "readHex" readHex s+      _ -> error "read_hex_byte"++read_hex_byte_seq :: (Eq t,Num t) => String -> [t]+read_hex_byte_seq = map read_hex_byte . words++-- | 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_byte_seq :: Integral i => FilePath -> [i] -> IO ()+store_byte_seq fn = B.writeFile fn . B.pack . map fromIntegral++-- | Load hexadecimal text 'U8' sequence from file.+load_hex_byte_seq :: Integral i => FilePath -> IO [i]+load_hex_byte_seq = fmap (map read_hex_byte . words) . readFile++-- | Store 'U8' sequence as hexadecimal text, 16 words per line.+store_hex_byte_seq :: (Integral i,Show i) => FilePath -> [i] -> IO ()+store_hex_byte_seq fn = writeFile fn . unlines . map unwords . chunksOf 16 . map byte_hex_pp_err

@@ -1,8 +1,8 @@ -- | Common music notation clefs. module Music.Theory.Clef where -import Music.Theory.Pitch-import Music.Theory.Pitch.Name+import Music.Theory.Pitch {- hmt -}+import Music.Theory.Pitch.Name {- hmt -}  -- | Clef enumeration type. data Clef_T = Bass | Tenor | Alto | Treble | Percussion

@@ -1,19 +1,19 @@ -- | Combination functions. module Music.Theory.Combinations where -import Music.Theory.Permutations+import qualified Music.Theory.Permutations as T  -- | Number of /k/ element combinations of a set of /n/ elements. -- -- > (nk_combinations 6 3,nk_combinations 13 3) == (20,286) nk_combinations :: Integral a => a -> a -> a-nk_combinations n k = nk_permutations n k `div` factorial k+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 :: Integral t => t -> [a] -> [[a]]+combinations :: Int -> [a] -> [[a]] combinations k s =     case (k,s) of       (0,_) -> [[]]

@@ -10,33 +10,13 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import qualified Music.Theory.Set.List as T+import qualified Music.Theory.List as T+import qualified Music.Theory.Ord as T import qualified Music.Theory.Permutations.List as T---- * List functions---- | Replace the /i/th value at /ns/ with /x/.------ > replace "test" 2 'n' == "tent"-replace :: Integral i => [a] -> i -> a -> [a]-replace ns i x =-    let f j y = if i == j then x else y-    in zipWith f [0..] ns---- | Are all elements equal.------ > all_equal "aaa" == True-all_equal :: Eq a => [a] -> Bool-all_equal xs = all id (zipWith (==) xs (tail xs))+import qualified Music.Theory.Set.List as T  -- * Indices --- | Compare adjacent elements (p.262) left to right.------ > compare_adjacent [0,1,3,2] == [LT,LT,GT]-compare_adjacent :: Ord a => [a] -> [Ordering]-compare_adjacent xs = zipWith compare xs (tail xs)- -- | Construct set of /n/ '-' @1@ adjacent indices, left right order. -- -- > adjacent_indices 5 == [(0,1),(1,2),(2,3),(3,4)]@@ -51,36 +31,6 @@     let n' = n - 1     in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']] --- * 'Enum' functions---- | Generic variant of 'fromEnum' (p.263).-genericFromEnum :: (Integral i,Enum e) => e -> i-genericFromEnum = fromIntegral . fromEnum---- | Generic variant of 'toEnum' (p.263).-genericToEnum :: (Integral i,Enum e) => i -> e-genericToEnum = toEnum . fromIntegral---- * 'Ordering' functions---- | Specialised 'genericFromEnum'.-ord_to_int :: Integral a => Ordering -> a-ord_to_int = genericFromEnum---- | Specialised 'genericToEnum'.-int_to_ord :: Integral a => a -> Ordering-int_to_ord = genericToEnum---- | Invert 'Ordering'.------ > map ord_invert [LT,EQ,GT] == [GT,EQ,LT]-ord_invert :: Ordering -> Ordering-ord_invert x =-    case x of-      LT -> GT-      EQ -> EQ-      GT -> LT- -- * Matrix  -- | A list notation for matrices.@@ -109,7 +59,7 @@ data Contour_Half_Matrix =     Contour_Half_Matrix {contour_half_matrix_n :: Int                         ,contour_half_matrix_m :: Matrix Ordering}-    deriving (Eq)+    deriving (Eq,Ord)  -- | Half 'Matrix' of contour given comparison function /f/. --@@ -183,7 +133,7 @@ -- > let c = ["abc","bbb","cba"] -- > in map (uniform.contour_description) c == [True,True,True] uniform :: Contour_Description -> Bool-uniform (Contour_Description _ m) = all_equal (M.elems m)+uniform (Contour_Description _ m) = T.all_equal (M.elems m)  -- | 'True' if contour does not containt any 'EQ' elements. --@@ -317,7 +267,7 @@                                             LT -> i' + adjustment j'                                             EQ -> i'                                             GT -> i' - adjustment j'-                                in Just (replace ns j j'')+                                in Just (T.replace_at ns j j'')         refine [] ns = ns         refine (i:is) ns = case step i ns of                              Nothing -> refine is ns@@ -330,7 +280,7 @@ -- > in draw_contour (contour_description_invert c) == [3,2,0,1] contour_description_invert :: Contour_Description -> Contour_Description contour_description_invert (Contour_Description n m) =-    Contour_Description n (M.map ord_invert m)+    Contour_Description n (M.map T.ord_invert m)  -- * Construction @@ -499,5 +449,5 @@ ex_4 =     let ns :: [[Int]]         ns = [[2,2,2,1],[2,2,0],[0,0],[1]]-        ns' = map (map int_to_ord) ns+        ns' = map (map T.int_to_ord) ns     in half_matrix_to_description (Contour_Half_Matrix 5 ns')

@@ -0,0 +1,24 @@+-- | Keys are given in the header, empty fields are omitted from records.+module Music.Theory.DB.CSV where++import Data.Maybe {- base -}+import qualified Text.CSV.Lazy.String as C {- lazy-csv -}++import Music.Theory.DB.Common {- hmt -}+import qualified Music.Theory.IO as T {- hmt -}++-- | Load 'DB' from 'FilePath'.+db_load_utf8 :: FilePath -> IO DB'+db_load_utf8 fn = do+  s <- T.read_file_utf8 fn+  let p = C.fromCSVTable (C.csvTable (C.parseCSV s))+      (h,d) = (head p,tail p)+      f k v = if null v then Nothing else Just (k,v)+  return (map (catMaybes . zipWith f h) d)++db_store_utf8 :: FilePath -> DB' -> IO ()+db_store_utf8 fn db = do+  let (hdr,tbl) = db_to_table (fromMaybe "") db+      (_,tbl') = C.toCSVTable (hdr : tbl)+      str = C.ppCSVTable tbl'+  T.write_file_utf8 fn str

@@ -0,0 +1,130 @@+module Music.Theory.DB.Common where++import Data.List {- base -}+import Data.Maybe {- base -}+import Safe {- safe -}++import qualified Music.Theory.List as T {- base -}+import qualified Music.Theory.Maybe as T {- base -}++-- * Type++type Entry k v = (k,v)+type Record k v = [Entry k v]+type DB k v = [Record k v]++type Key = String+type Value = String+type Entry' = Entry Key Value+type Record' = Record Key Value+type DB' = DB Key Value++-- * Record++-- | The sequence of keys at 'Record'.+record_key_seq :: Record k v -> [k]+record_key_seq = map fst++-- | 'True' if 'Key' is present in 'Entity'.+record_has_key :: Eq k => k -> Record k v -> Bool+record_has_key k = elem k . record_key_seq++-- | 'T.histogram' of 'record_key_seq'.+record_key_histogram :: Ord k => Record k v -> [(k,Int)]+record_key_histogram = T.histogram . record_key_seq++-- | Duplicate keys predicate.+record_has_duplicate_keys :: Ord k => Record k v -> Bool+record_has_duplicate_keys = any (> 0) . map snd . record_key_histogram++-- | Find all associations for key using given equality function.+record_lookup_by :: (k -> k -> Bool) -> k -> Record k v -> [v]+record_lookup_by f k = map snd . filter (f k . fst)++-- | 'record_lookup_by' of '=='.+record_lookup :: Eq k => k -> Record k v -> [v]+record_lookup = record_lookup_by (==)++-- | /n/th element of 'record_lookup'.+record_lookup_at :: Eq k => (k,Int) -> Record k v -> Maybe v+record_lookup_at (c,n) = flip atMay n . record_lookup c++-- | Variant of 'record_lookup' requiring a unique key.  'Nothing' indicates+-- there is no entry, it is an 'error' if duplicate keys are present.+record_lookup_uniq :: Eq k => k -> Record k v -> Maybe v+record_lookup_uniq k r =+    case record_lookup k r of+      [] -> Nothing+      [v] -> Just v+      _ -> error "record_lookup_uniq: non uniq"++-- | 'True' if key exists and is unique.+record_has_key_uniq :: Eq k => k -> Record k v -> Bool+record_has_key_uniq k = isJust . record_lookup_uniq k++-- | Error variant.+record_lookup_uniq_err :: Eq k => k -> Record k v -> v+record_lookup_uniq_err k = T.from_just "record_lookup_uniq: none" . record_lookup_uniq k++-- | Default value variant.+record_lookup_uniq_def :: Eq k => v -> k -> Record k v -> v+record_lookup_uniq_def v k = fromMaybe v . record_lookup_uniq k++-- | Remove all associations for key using given equality function.+record_delete_by :: (k -> k -> Bool) -> k -> Record k v -> Record k v+record_delete_by f k = filter (not . f k . fst)++-- | 'record_delete_by' of '=='.+record_delete :: Eq k => k -> Record k v -> Record k v+record_delete = record_delete_by (==)++-- * DB++-- | Preserves order of occurence.+db_key_set :: Ord k => DB k v -> [k]+db_key_set = nub . map fst . concat++db_lookup_by :: (k -> k -> Bool) -> (v -> v -> Bool) -> k -> v -> DB k v -> [Record k v]+db_lookup_by k_cmp v_cmp k v =+    let f = any (v_cmp v) . record_lookup_by k_cmp k+    in filter f++db_lookup :: (Eq k,Eq v) => k -> v -> DB k v -> [Record k v]+db_lookup = db_lookup_by (==) (==)++db_has_duplicate_keys :: Ord k => DB k v -> Bool+db_has_duplicate_keys = any id . map record_has_duplicate_keys++db_key_histogram :: Ord k => DB k v -> [(k,Int)]+db_key_histogram db =+    let h = concatMap record_key_histogram db+        f k = (k,maximum (record_lookup k h))+    in map f (db_key_set db)++db_to_table :: Ord k => (Maybe v -> e) -> DB k v -> ([k],[[e]])+db_to_table f db =+    let kh = db_key_histogram db+        hdr = concatMap (\(k,n) -> replicate n k) kh+        ix = concatMap (\(k,n) -> zip (repeat k) [0 .. n - 1]) kh+    in (hdr,map (\r -> map (\i -> f (record_lookup_at i r)) ix) db)++-- * Collating duplicate keys.++record_collate' :: Eq k => (k,[v]) -> Record k v -> Record k [v]+record_collate' (k,v) r =+    case r of+      [] -> [(k,reverse v)]+      (k',v'):r' ->+          if k == k'+          then record_collate' (k,v' : v) r'+          else (k,reverse v) : record_collate' (k',[v']) r'++-- | Collate adjacent entries of existing sequence with equal key.+record_collate :: Eq k => Record k v -> Record k [v]+record_collate r =+    case r of+      [] -> error "record_collate: nil"+      (k,v):r' -> record_collate' (k,[v]) r'++record_uncollate :: Record k [v] -> Record k v+record_uncollate = concatMap (\(k,v) -> zip (repeat k) v)

@@ -0,0 +1,67 @@+-- | JSON string association database.+-- JSON objects do no allow multiple keys.+-- Here multiple keys are read & written as arrays.+module Music.Theory.DB.JSON where++import qualified Data.Aeson as A {- aeson -}+import qualified Data.ByteString.Lazy as B {- bytestring -}+import qualified Data.Map as M {- containers -}++import qualified Music.Theory.DB.Common as DB++-- | Load 'DB' from 'FilePath'.+db_load_utf8 :: FilePath -> IO DB.DB'+db_load_utf8 fn = do+  b <- B.readFile fn+  case A.decode b of+    Just m ->+        let f = DB.record_uncollate .+                map (fmap maybe_list_to_list) .+                M.toList+        in return (map f m)+    Nothing -> return []++-- | Store 'DB' to 'FilePath'.+--+-- > let fn = "/home/rohan/ut/www-spr/data/db.js"+-- > db <- db_load_utf8 fn+-- > length db == 1334+-- > db_store_utf8 "/tmp/sp.js" db+db_store_utf8 :: FilePath -> DB.DB' -> IO ()+db_store_utf8 fn db = do+  let db' = let f = map (fmap list_to_maybe_list) . DB.record_collate+            in map f db+      b = A.encode (map M.fromList db')+  B.writeFile fn b++-- * Maybe List of String++data Maybe_List_Of_String = S String | L [String] deriving (Eq,Show)++maybe_list_to_list :: Maybe_List_Of_String -> [String]+maybe_list_to_list m =+    case m of+      S s -> [s]+      L l -> l++list_to_maybe_list :: [String] -> Maybe_List_Of_String+list_to_maybe_list l =+    case l of+      [s] -> S s+      _ -> L l++-- > A.toJSON (S "x")+-- > A.toJSON (L ["x","y"])+instance A.ToJSON Maybe_List_Of_String where+    toJSON (S s) = A.toJSON s+    toJSON (L l) = A.toJSON l++-- > :set -XOverloadedStrings+-- > A.decode "\"x\"" :: Maybe Maybe_List_Of_String+-- > A.decode "[\"x\",\"y\"]" :: Maybe Maybe_List_Of_String+instance A.FromJSON Maybe_List_Of_String where+    parseJSON v =+        case v of+          A.String _ -> fmap S (A.parseJSON v)+          A.Array _ -> fmap L (A.parseJSON v)+          _ -> error "parseJSON: Maybe_List_String"

@@ -0,0 +1,60 @@+-- | @key: value@ database, allows duplicate @key@s.+module Music.Theory.DB.Plain where++import Data.List {- base -}+import qualified Data.List.Split as Split {- split -}+import Data.Maybe {- base -}+import qualified Safe as Safe {- safe -}++import qualified Music.Theory.IO as IO {- hmt -}+import qualified Music.Theory.List as T {- hmt -}++-- | (RECORD-SEPARATOR,FIELD-SEPARATOR,ENTRY-SEPARATOR)+type SEP = (String,String,String)++type Key = String+type Value = String+type Entry = (Key,[Value])+type Record = [Entry]+type DB = [Record]++sep_plain :: SEP+sep_plain = (['\n','\n'],['\n'],": ")++-- > record_parse (";","=") "F=f/rec;E=au;C=A;K=P;K=Q"+record_parse :: (String,String) -> String -> Record+record_parse (fs,es) = T.collate_adjacent . mapMaybe (T.separate_at es) . Split.splitOn fs++record_lookup :: Key -> Record -> [Value]+record_lookup k = fromMaybe [] . lookup k++record_lookup_at :: (Key,Int) -> Record -> Maybe Value+record_lookup_at (k,n) = flip Safe.atMay n . record_lookup k++record_has_key :: Key -> Record -> Bool+record_has_key k = isJust . lookup k++record_lookup_uniq :: Key -> Record -> Maybe Value+record_lookup_uniq k r =+    case record_lookup k r of+      [] -> Nothing+      [v] -> Just v+      _ -> error "record_lookup_uniq: non uniq"++db_parse :: SEP -> String -> [Record]+db_parse (rs,fs,es) s =+    let r = Split.splitOn rs s+    in map (record_parse (fs,es)) r++db_sort :: [(Key,Int)] -> [Record] -> [Record]+db_sort k = T.sort_by_n_stage (map record_lookup_at k)++db_load_utf8 :: SEP -> FilePath -> IO [Record]+db_load_utf8 sep = fmap (db_parse sep) . IO.read_file_utf8++-- > record_pp (";","=") [("F","f/rec.au"),("C","A")]+record_pp :: (String,String) -> Record -> String+record_pp (fs,es) = intercalate fs . map (\(k,v) -> k ++ es ++ v) . T.uncollate++db_store_utf8 :: SEP -> FilePath -> [Record] -> IO ()+db_store_utf8 (rs,fs,es) fn = IO.write_file_utf8 fn . intercalate rs . map (record_pp (fs,es))

@@ -0,0 +1,38 @@+-- | Directory functions.+module Music.Theory.Directory where++import Data.List {- base -}+import Data.Maybe {- base -}+import System.Directory {- directory -}+import System.FilePath {- filepath -}++-- | Scan a list of directories until a file is located, or not.+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++path_scan_err :: [FilePath] -> FilePath -> IO FilePath+path_scan_err p x =+    let err = (error ("path_scan: " ++ show p ++ ": " ++ x))+    in fmap (fromMaybe err) (path_scan p x)++-- | Subset of files in /dir/ with an extension in /ext/.+dir_subset :: [String] -> FilePath -> IO [FilePath]+dir_subset ext dir = do+  let f nm = takeExtension nm `elem` ext+  c <- getDirectoryContents dir+  return (map (dir </>) (sort (filter f c)))++-- | 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+

@@ -6,6 +6,9 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} +import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Ord as T {- hmt -}+ -- | Common music notation durational model data Duration = Duration {division :: Integer -- ^ division of whole note                          ,dots :: Integer -- ^ number of dots@@ -17,6 +20,10 @@ duration_meq :: Duration -> Duration -> Bool duration_meq p q = multiplier p == multiplier q +-- | Is multiplier the identity (ie. @1@)?+duration_m1 :: Duration -> Bool+duration_m1 = (== 1) . multiplier+ -- | Compare durations with equal multipliers. duration_compare_meq :: Duration -> Duration -> Maybe Ordering duration_compare_meq y0 y1 =@@ -40,22 +47,6 @@ instance Ord Duration where     compare = duration_compare_meq_err -order_pair :: Ordering -> (t,t) -> (t,t)-order_pair o (x,y) =-    case o of-      LT -> (x,y)-      EQ -> (x,y)-      GT -> (y,x)---- | Sort a pair of equal type values using given comparison function.------ > sort_pair compare ('b','a') == ('a','b')-sort_pair :: (t -> t -> Ordering) -> (t,t) -> (t,t)-sort_pair fn (x,y) = order_pair (fn x y) (x,y)--sort_pair_m :: (t -> t -> Maybe Ordering) -> (t,t) -> Maybe (t,t)-sort_pair_m fn (x,y) = fmap (`order_pair` (x,y)) (fn x y)- -- | True if neither duration is dotted. no_dots :: (Duration, Duration) -> Bool no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0@@ -102,100 +93,134 @@                     then sum_dur_undotted (division x0, division x1)                     else sum_dur_dotted (division x0, dots x0                                         ,division x1, dots x1)-    in join (fmap f (sort_pair_m duration_compare_meq (y0,y1)))+    in join (fmap f (T.sort_pair_m duration_compare_meq (y0,y1)))  -- | Erroring variant of 'sum_dur'.-sum_dur' :: Duration -> Duration -> Duration-sum_dur' y0 y1 =+sum_dur_err :: Duration -> Duration -> Duration+sum_dur_err y0 y1 =     let y2 = sum_dur y0 y1         err = error ("sum_dur': " ++ show (y0,y1))     in fromMaybe err y2 --- | Give @MusicXML@ type for division.+-- | Standard divisions (from 0 to 256).  MusicXML allows @-1@ as a division (for @long@).+divisions_set :: [Integer]+divisions_set = [0,1,2,4,8,16,32,64,128,256]++-- | Durations set derived from 'divisions_set' with up to /k/ dots.  Multiplier of @1@.+duration_set :: Integer -> [Duration]+duration_set k = [Duration dv dt 1 | dv <- divisions_set, dt <- [0..k]]++-- | Table of number of beams at notated division.+beam_count_tbl :: [(Integer,Integer)]+beam_count_tbl = zip (-1 : divisions_set) [0,0,0,0,0,1,2,3,4,5,6]++-- | Lookup 'beam_count_tbl'. --+-- > whole_note_division_to_beam_count 32 == Just 3+whole_note_division_to_beam_count :: Integer -> Maybe Integer+whole_note_division_to_beam_count x = lookup x beam_count_tbl++-- | Calculate number of beams at 'Duration'.+--+-- > map duration_beam_count [Duration 2 0 1,Duration 16 0 1] == [0,2]+duration_beam_count :: Duration -> Integer+duration_beam_count (Duration x _ _) =+    let err = error "duration_beam_count"+        bc = whole_note_division_to_beam_count x+    in fromMaybe err bc++-- * MusicXML++-- | Table giving @MusicXML@ types for divisions.+division_musicxml_tbl :: [(Integer,String)]+division_musicxml_tbl =+    let nm = ["long","breve","whole","half","quarter","eighth"+             ,"16th","32nd","64th","128th","256th"]+    in zip (-1 : divisions_set) nm++-- | Lookup 'division_musicxml_tbl'.+-- -- > map whole_note_division_to_musicxml_type [2,4] == ["half","quarter"] whole_note_division_to_musicxml_type :: Integer -> String whole_note_division_to_musicxml_type x =-    case x of-      256 -> "256th"-      128 -> "128th"-      64 -> "64th"-      32 -> "32nd"-      16 -> "16th"-      8 -> "eighth"-      4 -> "quarter"-      2 -> "half"-      1 -> "whole"-      0 -> "breve"-      -1 -> "long"-      _ -> error ("whole_note_division_to_musicxml_type: " ++ show x)+    T.lookup_err_msg "division_musicxml_tbl" x division_musicxml_tbl  -- | Variant of 'whole_note_division_to_musicxml_type' extracting--- 'division' from 'Duration'.+-- 'division' from 'Duration', dots & multipler are ignored. ----- > duration_to_musicxml_type quarter_note == "quarter"+-- > duration_to_musicxml_type (Duration 4 0 1) == "quarter" duration_to_musicxml_type :: Duration -> String duration_to_musicxml_type = whole_note_division_to_musicxml_type . division +-- * Unicode++-- | Table giving @Unicode@ symbols for divisions.+division_unicode_tbl :: [(Integer,Char)]+division_unicode_tbl = zip [0,1,2,4,8,16,32,64,128,256] "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲"++-- | Lookup 'division_unicode_tbl'.+--+-- > map whole_note_division_to_unicode_symbol [1,2,4,8] == "𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮"+whole_note_division_to_unicode_symbol :: Integer -> Char+whole_note_division_to_unicode_symbol x =+    T.lookup_err_msg "division_unicode_tbl" x division_unicode_tbl++-- | Give Unicode string for 'Duration'. The duration multiplier is /not/ written.+--+-- > map duration_to_unicode [Duration 1 2 1,Duration 4 1 1] == ["𝅝𝅭𝅭","𝅘𝅥𝅭"]+duration_to_unicode :: Duration -> String+duration_to_unicode (Duration dv d _) =+    let dv' = whole_note_division_to_unicode_symbol dv+    in dv' : replicate (fromIntegral d) '𝅭'++-- * Lilypond+ -- | Give /Lilypond/ notation for 'Duration'.  Note that the duration -- multiplier is /not/ written. ----- > import Music.Theory.Duration.Name--- > map duration_to_lilypond_type [half_note,dotted_quarter_note] == ["2","4."]+-- > map duration_to_lilypond_type [Duration 2 0 1,Duration 4 1 1] == ["2","4."] duration_to_lilypond_type :: Duration -> String duration_to_lilypond_type (Duration dv d _) =     let dv' = if dv == 0 then "\\breve" else show dv     in dv' ++ replicate (fromIntegral d) '.' --- | Calculate number of beams at notated division.------ > whole_note_division_to_beam_count 32 == Just 3-whole_note_division_to_beam_count :: Integer -> Maybe Integer-whole_note_division_to_beam_count x =-    let t = [(256,6),(128,5),(64,4),(32,3),(16,2),(8,1)-            ,(4,0),(2,0),(1,0),(0,0),(-1,0)]-    in lookup x t+-- * Humdrum --- | Calculate number of beams at 'Duration'.------ > map duration_beam_count [half_note,sixteenth_note] == [0,2]-duration_beam_count :: Duration -> Integer-duration_beam_count (Duration x _ _) =-    let err = error "duration_beam_count"-        bc = whole_note_division_to_beam_count x-    in fromMaybe err bc+{- | Duration to @**recip@ notation. -whole_note_division_pp :: Integer -> Maybe Char-whole_note_division_pp x =+<http://humdrum.org/Humdrum/representations/recip.rep.html>++> let d = map (\z -> Duration z 0 1) [0,1,2,4,8,16,32]+> in map duration_recip_pp d == ["0","1","2","4","8","16","32"]++> let d = [Duration 1 1 (1/3),Duration 4 1 1,Duration 4 1 (2/3)]+> in map duration_recip_pp d == ["3.","4.","6."]++-}+duration_recip_pp :: Duration -> String+duration_recip_pp (Duration x d m) =+    let (mn,md) = (numerator m,denominator m)+        r = (x % mn) * (md % 1)+    in if denominator r == 1+       then show (numerator r) ++ genericReplicate d '.'+       else error (show ("duration_recip_pp",x,d,m,r))++-- * Letter++whole_note_division_letter_pp :: Integer -> Maybe Char+whole_note_division_letter_pp x =     let t = [(16,'s'),(8,'e'),(4,'q'),(2,'h'),(1,'w')]     in lookup x t --- > import Music.Theory.Duration.Name.Abbreviation--- > map duration_pp [q,h',e''] == [Just "q",Just "h'",Just "e''"]-duration_pp :: Duration -> Maybe String-duration_pp (Duration x d m) =+-- > mapMaybe duration_letter_pp [Duration 4 0 1,Duration 2 1 1,Duration 8 2 1] == ["q","h'","e''"]+-- > duration_letter_pp+duration_letter_pp :: Duration -> Maybe String+duration_letter_pp (Duration x d m) =     let d' = genericReplicate d '\''         m' = case (numerator m,denominator m) of                (1,1) -> ""                (1,i) -> '/' : show i                (i,j) -> '*' : show i ++ "/" ++ show j-    in case whole_note_division_pp x of+    in case whole_note_division_letter_pp x of          Just x' -> Just (x' : d' ++ m')          _ -> Nothing---- | Duration to @**recip@ notation.------ http://humdrum.org/Humdrum/representations/recip.rep.html------ > let d = map (\z -> Duration z 0 1) [0,1,2,4,8,16,32]--- > in map duration_recip_pp d == ["0","1","2","4","8","16","32"]------ > let d = [Duration 1 1 (1/3),Duration 4 1 1,Duration 4 1 (2/3)]--- > in map duration_recip_pp d == ["3.","4.","6."]-duration_recip_pp :: Duration -> String-duration_recip_pp (Duration x d m) =-    let (mn,md) = (numerator m,denominator m)-        r = (x % mn) * (md % 1)-    in if denominator r == 1-       then show (numerator r) ++ genericReplicate d '.'-       else error (show ("duration_recip_pp",x,d,m,r))

@@ -3,11 +3,11 @@  import Data.Maybe {- base -} import Data.Ratio {- base -}-import qualified Data.Traversable as T {- base -} import Data.Tree {- containers -}  import Music.Theory.Duration import Music.Theory.Duration.RQ+import qualified Music.Theory.List as L {- hmt -}  -- | Standard music notation durational model annotations data D_Annotation = Tie_Right@@ -63,52 +63,6 @@         jn (p,q) z = (p,q++z)     in zipWith jn (map fn x) ts --- | Transform predicates into 'Ordering' predicate such that if /f/--- holds then 'LT', if /g/ holds then 'GT' else 'EQ'.------ > map (begin_end_cmp (== '{') (== '}')) "{a}" == [LT,EQ,GT]-begin_end_cmp :: (t -> Bool) -> (t -> Bool) -> t -> Ordering-begin_end_cmp f g x = if f x then LT else if g x then GT else EQ---- | Variant of 'begin_end_cmp', predicates are constructed by '=='.------ > map (begin_end_cmp_eq '{' '}') "{a}" == [LT,EQ,GT]-begin_end_cmp_eq :: Eq t => t -> t -> t -> Ordering-begin_end_cmp_eq p q = begin_end_cmp (== p) (== q)---- | Given an 'Ordering' predicate where 'LT' opens a group, 'GT'--- closes a group, and 'EQ' continues current group, construct tree--- from list.------ > let {l = "a {b {c d} e f} g h i"--- >     ;t = group_tree (begin_end_cmp_eq '{' '}') l}--- > in catMaybes (flatten t) == l------ > let d = putStrLn . drawTree . fmap show--- > in d (group_tree (begin_end_cmp_eq '(' ')') "a(b(cd)ef)ghi")-group_tree :: (a -> Ordering) -> [a] -> Tree (Maybe a)-group_tree f =-    let unit e = Node (Just e) []-        nil = Node Nothing []-        insert_e (Node t l) e = Node t (e:l)-        reverse_n (Node t l) = Node t (reverse l)-        push (r,z) e = case z of-                         h:z' -> (r,insert_e h (unit e) : z')-                         [] -> (unit e : r,[])-        open (r,z) = (r,nil:z)-        close (r,z) = case z of-                        h0:h1:z' -> (r,insert_e h1 (reverse_n h0) : z')-                        h:z' -> (reverse_n h : r,z')-                        [] -> (r,z)-        go st x =-            case x of-              [] -> Node Nothing (reverse (fst st))-              e:x' -> case f e of-                        LT -> go (push (open st) e) x'-                        EQ -> go (push st e) x'-                        GT -> go (close (push st e)) x'-    in go ([],[])- -- | Group tuplets into a 'Tree'.  Branch nodes have label 'Nothing', -- leaf nodes label 'Just' 'Duration_A'. --@@ -121,9 +75,7 @@ -- >         ,(q,[])] -- > in catMaybes (flatten (da_group_tuplets d)) == d da_group_tuplets :: [Duration_A] -> Tree (Maybe Duration_A)-da_group_tuplets =-    let f = begin_end_cmp da_begins_tuplet da_ends_tuplet-    in group_tree f+da_group_tuplets = L.group_tree (da_begins_tuplet,da_ends_tuplet)  -- | Variant of 'break' that places separator at left. --@@ -165,22 +117,11 @@                    in Right (d : t) : da_group_tuplets_nn x''               else Left d : da_group_tuplets_nn x' --- | Keep right variant of 'zipWith', unused rhs values are returned.------ > zip_with_kr (,) [1..3] ['a'..'e'] == ([(1,'a'),(2,'b'),(3,'c')],"de")-zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])-zip_with_kr f =-    let go r p q =-            case (p,q) of-              (i:p',j:q') -> go (f i j : r) p' q'-              _ -> (reverse r,q)-    in go []- -- | Keep right variant of 'zip', unused rhs values are returned. -- -- > zip_kr [1..4] ['a'..'f'] == ([(1,'a'),(2,'b'),(3,'c'),(4,'d')],"ef") zip_kr :: [a] -> [b] -> ([(a,b)],[b])-zip_kr = zip_with_kr (,)+zip_kr = L.zip_with_kr (,)  -- | 'zipWith' variant that adopts the shape of the lhs. --@@ -192,31 +133,9 @@     case (p,q) of       (e:p',i:q') -> case e of                        Left j -> Left (f j i) : nn_reshape f p' q'-                       Right j -> let (j',q'') = zip_with_kr f j q+                       Right j -> let (j',q'') = L.zip_with_kr f j q                                   in Right j' : nn_reshape f p' q''       _ -> []---- | Replace elements at 'Traversable' with result of joining with--- elements from list.-adopt_shape :: T.Traversable t => (a -> b -> c) -> [b] -> t a -> t c-adopt_shape jn l =-    let f (i:j) k = (j,jn k i)-        f [] _ = error "adopt_shape: rhs ends"-    in snd . T.mapAccumL f l---- | Variant of 'adopt_shape' that considers only 'Just' elements at--- 'Traversable'.------ > let {s = "a(b(cd)ef)ghi"--- >     ;t = group_tree (begin_end_cmp_eq '(' ')') s}--- > in adopt_shape_m (,) [1..13] t-adopt_shape_m :: T.Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> t (Maybe c)-adopt_shape_m jn l =-    let f (i:j) k = case k of-                      Nothing -> (i:j,Nothing)-                      Just k' -> (j,Just (jn k' i))-        f [] _ = error "adopt_shape_m: rhs ends"-    in snd . T.mapAccumL f l  -- | Does /a/ have 'Tie_Left' and 'Tie_Right'? d_annotated_tied_lr :: [D_Annotation] -> (Bool,Bool)

@@ -124,7 +124,7 @@  ct_measure:: T.Lseq T.RQ T.RQ -> ([T.RQ],Maybe Char,Maybe (),[[T.RQ]]) -> [(Rational,CT_Node)] ct_measure sq (mrq,mk,pr,dv) =-    let dv' = concatMap (zip [1..]) dv+    let dv' = concatMap (zip [1::Int ..]) dv         f (p,rq,(g,du)) =             let nm = if p == 1                      then case mk of@@ -134,7 +134,7 @@                           then CT_Pre du                           else if g == 1 then CT_Edge du else CT_Normal du             in (du * (60 / ct_tempo_at sq rq),nm)-    in map f (zip3 [1..] mrq dv')+    in map f (zip3 [1::Int ..] mrq dv')  -- | Click track definition. data CT = CT {ct_len :: Int

@@ -2,7 +2,8 @@ -- There are /letter/ names where 'w' is 'whole_note' and so on, and -- /numerical/ names where '_4' is 'quarter_note' and so on.  In both -- cases a @'@ extension means a @dot@ so that 'e''' is a double--- dotted 'eighth_note'.+-- dotted 'eighth_note'.  The prefix is @_@ not @d@ since @d4@ etc. are+-- also note names. -- -- > zipWith duration_compare_meq [e,e,e,e'] [e,s,q,e] == [EQ,GT,LT,GT] -- > zipWith sum_dur [e,q,q'] [e,e,e] == [Just q,Just q',Just h]

@@ -6,36 +6,22 @@ import Data.Maybe {- base -} import Data.Ratio {- base -} -import Music.Theory.Duration-import Music.Theory.Duration.Name+import Music.Theory.Duration {- hmt -}  -- | Rational Quarter-Note type RQ = Rational +-- > rq_duration_tbl 2+rq_duration_tbl :: Integer -> [(Rational,Duration)]+rq_duration_tbl k = map (\d -> (duration_to_rq d,d)) (duration_set k)+ -- | Rational quarter note to duration value.  It is a mistake to hope -- this could handle tuplets directly since, for instance, a @3:2@ -- dotted note will be of the same duration as a plain undotted note. -- -- > rq_to_duration (3/4) == Just dotted_eighth_note rq_to_duration :: RQ -> Maybe Duration-rq_to_duration x =-    case (numerator x,denominator x) of-      (1,8) -> Just thirtysecond_note-      (3,16) -> Just dotted_thirtysecond_note-      (1,4) -> Just sixteenth_note-      (3,8) -> Just dotted_sixteenth_note-      (1,2) -> Just eighth_note-      (3,4) -> Just dotted_eighth_note-      (1,1) -> Just quarter_note-      (3,2) -> Just dotted_quarter_note-      (2,1) -> Just half_note-      (3,1) -> Just dotted_half_note-      (7,2) -> Just double_dotted_half_note-      (4,1) -> Just whole_note-      (6,1) -> Just dotted_whole_note-      (8,1) -> Just breve-      (12,1) -> Just dotted_breve-      _ -> Nothing+rq_to_duration x = lookup x (rq_duration_tbl 2)  -- | Is 'RQ' a /cmn/ duration. --

@@ -17,7 +17,6 @@ -- 5. Ascribe values to notated durations, see 'ascribe'. module Music.Theory.Duration.Sequence.Notate where -import Control.Applicative {- base -} import Control.Monad {- base -} import Data.List {- base -} import Data.List.Split {- split -}@@ -646,6 +645,14 @@         z i (j,_) = i + duration_to_rq j     in coalesce_sum z 0 f +-- | Run simplifier until it reaches a fix-point, or for at most 'limit' passes.+m_simplify_fix :: Int -> Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]+m_simplify_fix limit p ts d =+    let d' = m_simplify p ts d+    in if d == d' || limit == 1+       then d'+       else m_simplify_fix (limit - 1) p ts d'+ -- | Pulse simplifier predicate, which is 'const' 'True'. p_simplify_rule :: Simplify_P p_simplify_rule = const True@@ -674,23 +681,23 @@ >      ts_p = [[1/2,1,1/2],[1/2,1]] >      rq = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3] >      sr x = T.default_rule [] x->  in T.notate_rqp sr ts (Just ts_p) rq+>  in T.notate_rqp 4 sr ts (Just ts_p) rq  -}-notate_rqp :: Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] ->+notate_rqp :: Int -> Simplify_P -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] ->               Either String [[Duration_A]]-notate_rqp r ts ts_p x = do+notate_rqp limit r ts ts_p x = do   let ts_p' = fromMaybe (map ts_divisions ts) ts_p   mm <- to_divisions_rq ts_p' x   dd <- mm_notate mm-  return (zipWith (m_simplify r) ts dd)+  return (zipWith (m_simplify_fix limit r) ts dd)  -- | Variant of 'notate_rqp' without pulse divisions (derive). ----- > notate (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6]-notate :: Simplify_P -> [Time_Signature] -> [RQ] ->+-- > notate 4 (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6]+notate :: Int -> Simplify_P -> [Time_Signature] -> [RQ] ->           Either String [[Duration_A]]-notate r ts x = notate_rqp r ts Nothing x+notate limit r ts x = notate_rqp limit r ts Nothing x  -- * Ascribe @@ -772,17 +779,17 @@                in r : mm_ascribe mm' x'  -- | 'mm_ascribe of 'notate'.-notate_mm_ascribe :: Show a => [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] ->+notate_mm_ascribe :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] ->                      Either String [[(Duration_A,a)]]-notate_mm_ascribe r ts rqp d p =-    let n = notate_rqp (default_rule r) ts rqp d+notate_mm_ascribe limit r ts rqp d p =+    let n = notate_rqp limit (default_rule r) ts rqp d         f = flip mm_ascribe p         err str = show ("notate_ascribe",str,ts,d,p)     in either (Left . err) (Right . f) n -notate_mm_ascribe_err :: Show a => [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] ->+notate_mm_ascribe_err :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] ->                          [[(Duration_A,a)]]-notate_mm_ascribe_err = either error id .:::: notate_mm_ascribe+notate_mm_ascribe_err = either error id .::::: notate_mm_ascribe  -- | Group elements as /chords/ where a chord element is indicated by -- the given predicate.

@@ -33,7 +33,7 @@ -- | Map midi velocity (0-127) to dynamic mark. -- -- > histogram (mapMaybe midi_dynamic_mark [0 .. 127])-midi_dynamic_mark :: (Ord n,Eq n,Num n,Enum n) => n -> Maybe Dynamic_Mark_T+midi_dynamic_mark :: (Ord n,Num n,Enum n) => n -> Maybe Dynamic_Mark_T midi_dynamic_mark m =     let r = zip (0 : [12,24 .. 132]) [0..]     in fmap (toEnum . snd) (find ((>= m) . fst) r)

@@ -0,0 +1,38 @@+-- | Enumeration functions.+module Music.Theory.Enum where++-- | Generic variant of 'fromEnum' (p.263).+genericFromEnum :: (Integral i,Enum e) => e -> i+genericFromEnum = fromIntegral . fromEnum++-- | Generic variant of 'toEnum' (p.263).+genericToEnum :: (Integral i,Enum e) => i -> e+genericToEnum = toEnum . fromIntegral++-- | Variant of 'enumFromTo' that, if /p/ is after /q/, cycles from+-- 'maxBound' to 'minBound'.+--+-- > import Data.Word+-- > enum_from_to_cyclic (254 :: Word8) 1 == [254,255,0,1]+enum_from_to_cyclic :: (Bounded a, Enum a) => a -> a -> [a]+enum_from_to_cyclic p q =+    if fromEnum p > fromEnum q+    then [p .. maxBound] ++ [minBound .. q]+    else [p .. q]++-- | Variant of 'enumFromTo' that, if /p/ is after /q/, enumerates+-- from /q/ to /p/.+--+-- > enum_from_to_reverse 5 1 == [5,4,3,2,1]+-- > enum_from_to_reverse 1 5 == enumFromTo 1 5+enum_from_to_reverse :: Enum a => a -> a -> [a]+enum_from_to_reverse p q =+    if fromEnum p > fromEnum q+    then reverse [q .. p]+    else [p .. q]++-- | All elements in sequence.+--+-- > (enum_univ :: [Data.Word.Word8]) == [0 .. 255]+enum_univ :: (Bounded t,Enum t) => [t]+enum_univ = [minBound .. maxBound]

@@ -1,6 +1,13 @@ -- | "Data.Function" related functions. module Music.Theory.Function where +-- | '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.@@ -18,7 +25,7 @@ predicate_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool predicate_or f g x = f x || g x --- | 'any' of predicates.+-- | 'any' of predicates, ie. logical /or/ of list of predicates. -- -- > let r = [True,False,True,False,True,True] -- > in map (predicate_any [(== 0),(== 5),even]) [0..5] == r

@@ -0,0 +1,325 @@+module Music.Theory.Gamelan where++import Data.Char {- base -}+import Data.Function {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Ratio {- base -}+import Text.Printf {- base -}++import qualified Music.Theory.Clef as T {- hmt -}+import qualified Music.Theory.Enum as T {- hmt -}+import qualified Music.Theory.Pitch as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.ET as T {- hmt-diagrams -}++-- | 'fromJust' with error message.+fromJust_err :: String -> Maybe a -> a+fromJust_err err = fromMaybe (error err)++-- | 'approxRational' of 0.01.+near_rat :: Double -> Rational+near_rat = flip approxRational 0.01++-- * Gamelan++-- | Enumeration of gamelan instrument families.+data Instrument_Family+    = Bonang+    | Gender+    | Gong+    | Saron+      deriving (Enum,Bounded,Eq,Ord,Show,Read)++-- | Universe+instrument_family_set :: [Instrument_Family]+instrument_family_set = T.enum_univ++-- | Enumeration of Gamelan instruments.+data Instrument_Name+    = Bonang_Barung -- ^ Bonang Barung (horizontal gong, middle)+    | Bonang_Panerus -- ^ Bonang Panerus (horizontal gong, high)+    | Gender_Barung -- ^ Gender Barung (key&resonator, middle)+    | Gender_Panerus -- ^ Gender Panembung (key&resonator, high)+    | Gender_Panembung -- ^ Gender Panembung, Slenthem (key&resonator, low)+    | Gong_Ageng -- ^ Gong Ageng (hanging gong, low)+    | Gong_Suwukan -- ^ Gong Suwukan (hanging gong, middle)+    | Kempul -- ^ Kempul (hanging gong, middle)+    | Kempyang -- ^ Kempyang (horizontal gong, high)+    | Kenong -- ^ Kenong (horizontal gong, low)+    | Ketuk -- ^ Ketuk (horizontal gong, middle)+    | Saron_Barung -- ^ Saron Barung, Saron (key, middle)+    | Saron_Demung -- ^ Saron Demung, Demung (key, low)+    | Saron_Panerus -- ^ Saron Panerus, Peking (key, high)+      deriving (Enum,Bounded,Eq,Ord,Show,Read)++instrument_family :: Instrument_Name -> Maybe Instrument_Family+instrument_family nm =+    case nm of+      Bonang_Barung -> Just Bonang+      Bonang_Panerus -> Just Bonang+      Gender_Barung -> Just Gender+      Gender_Panerus -> Just Gender+      Gender_Panembung -> Just Gender+      Gong_Ageng -> Just Gong+      Gong_Suwukan -> Just Gong+      Kempul -> Just Gong+      Kempyang -> Nothing+      Kenong -> Nothing+      Ketuk -> Nothing+      Saron_Barung -> Just Saron+      Saron_Demung -> Just Saron+      Saron_Panerus -> Just Saron++instrument_name_pp :: Instrument_Name -> String+instrument_name_pp =+    let f c = if c == '_' then ' ' else c+    in map f . show++-- | 'Clef' appropriate for 'Instrument_Name'.+instrument_name_clef :: Integral i => Instrument_Name -> T.Clef i+instrument_name_clef nm =+    case nm of+      Bonang_Barung -> T.Clef T.Treble 0+      Bonang_Panerus -> T.Clef T.Treble 1+      Gender_Barung -> T.Clef T.Treble 0+      Gender_Panerus -> T.Clef T.Treble 1+      Gender_Panembung -> T.Clef T.Bass 0+      Gong_Ageng -> T.Clef T.Bass 0+      Gong_Suwukan -> T.Clef T.Bass 0+      Kempul -> T.Clef T.Bass 0+      Kempyang -> T.Clef T.Treble 1+      Kenong -> T.Clef T.Treble 0+      Ketuk -> T.Clef T.Alto 0+      Saron_Barung -> T.Clef T.Treble 0+      Saron_Demung -> T.Clef T.Treble 0+      Saron_Panerus -> T.Clef T.Treble 1++instrument_name_clef_plain :: Integral i => Instrument_Name -> T.Clef i+instrument_name_clef_plain = T.clef_zero . instrument_name_clef++-- | Enumeration of Gamelan scales.+data Scale = Pelog | Slendro deriving (Enum,Eq,Ord,Show,Read)++type Octave = Integer+type Degree = Integer+type Frequency = Double+type Annotation = String++data Pitch = Pitch {pitch_octave :: Octave+                   ,pitch_degree :: Degree}+             deriving (Eq,Ord,Show)++pitch_pp_ascii :: Pitch -> String+pitch_pp_ascii (Pitch o d) =+    let d' = intToDigit (fromIntegral d)+        o' = if o < 0+             then genericReplicate (abs o) '-'+             else genericReplicate o '+'+    in o' ++ [d']++pitch_pp_duple :: Pitch -> String+pitch_pp_duple (Pitch o d) = printf "(%d,%d)" o d++data Note = Note {note_scale :: Scale+                 ,note_pitch :: Pitch}+             deriving (Eq,Ord,Show)++note_degree :: Note -> Degree+note_degree = pitch_degree . note_pitch++data Tone = Tone {tone_instrument_name :: Instrument_Name+                 ,tone_note :: Maybe Note+                 ,tone_frequency :: Maybe Frequency+                 ,tone_annotation :: Maybe Annotation}+             deriving (Eq,Show)++tone_frequency_err :: Tone -> Frequency+tone_frequency_err = fromJust_err "tone_frequency" . tone_frequency++-- | Orderable if frequency is given.+instance Ord Tone where compare = tone_compare_frequency++-- | Constructor for 'Tone' without /frequency/ or /annotation/.+plain_tone :: Instrument_Name -> Scale -> Octave -> Degree -> Tone+plain_tone nm sc o d = Tone nm (Just (Note sc (Pitch o d))) Nothing Nothing++-- | Tones are considered /equivalent/ if they have the same+-- 'Instrument_Name' and 'Note'.+tone_equivalent :: Tone -> Tone -> Bool+tone_equivalent p q =+    let Tone nm nt _ _ = p+        Tone nm' nt' _ _ = q+    in nm == nm' && nt == nt'++tone_24et_pitch :: Tone -> Maybe T.Pitch+tone_24et_pitch =+    let f i = let (_,pt,_,_,_) = T.nearest_24et_tone i in pt+    in fmap f . tone_frequency++tone_24et_pitch' :: Tone -> T.Pitch+tone_24et_pitch' = fromJust_err "tone_24et_pitch" . tone_24et_pitch++tone_24et_pitch_detune :: Tone -> Maybe T.Pitch_Detune+tone_24et_pitch_detune = fmap T.nearest_pitch_detune_24et . tone_frequency++tone_24et_pitch_detune' :: Tone -> T.Pitch_Detune+tone_24et_pitch_detune' = fromJust_err "tone_24et_pitch_detune" . tone_24et_pitch_detune++tone_fmidi :: Tone -> Double+tone_fmidi = T.cps_to_fmidi . tone_frequency_err++-- | Fractional (rational) 24-et midi note number of 'Tone'.+tone_24et_fmidi :: Tone -> Rational+tone_24et_fmidi = near_rat . T.pitch_to_fmidi . tone_24et_pitch'++tone_12et_pitch :: Tone -> Maybe T.Pitch+tone_12et_pitch =+    let f i = let (_,pt,_,_,_) = T.nearest_12et_tone i in pt+    in fmap f . tone_frequency++tone_12et_pitch' :: Tone -> T.Pitch+tone_12et_pitch' = fromJust_err "tone_12et_pitch" . tone_12et_pitch++tone_12et_pitch_detune :: Tone -> Maybe T.Pitch_Detune+tone_12et_pitch_detune = fmap T.nearest_pitch_detune_12et . tone_frequency++tone_12et_pitch_detune' :: Tone -> T.Pitch_Detune+tone_12et_pitch_detune' = fromJust_err "tone_12et_pitch_detune" . tone_12et_pitch_detune++-- | Fractional (rational) 24-et midi note number of 'Tone'.+tone_12et_fmidi :: Tone -> Rational+tone_12et_fmidi = near_rat . T.pitch_to_fmidi . tone_12et_pitch'++tone_family :: Tone -> Maybe Instrument_Family+tone_family = instrument_family . tone_instrument_name++tone_family_err :: Tone -> Instrument_Family+tone_family_err = fromJust_err "tone_family" . tone_family++tone_in_family :: Instrument_Family -> Tone -> Bool+tone_in_family c t = tone_family t == Just c++select_tones :: Instrument_Family -> [Tone] -> [Maybe Tone]+select_tones c =+    let f t = if tone_family t == Just c then Just t else Nothing+    in map f++-- | Specify subset as list of families and scales.+type Tone_Subset = ([Instrument_Family],[Scale])++-- | Extract subset of 'Tone_Set'.+tone_subset :: Tone_Subset -> Tone_Set -> Tone_Set+tone_subset (fm,sc) =+    let f t = fromJust_err "tone_subset" (tone_family t) `elem` fm &&+              fromJust_err "tone_subset" (tone_scale t) `elem` sc+    in filter f++data Instrument = Instrument {instrument_name :: Instrument_Name+                             ,instrument_scale :: Maybe Scale+                             ,instrument_pitches :: Maybe [Pitch]+                             ,instrument_frequencies :: Maybe [Frequency]}+                  deriving (Eq,Show)++type Tone_Set = [Tone]+type Tone_Group = [Tone_Set]+type Gamelan = [Instrument]++tone_scale :: Tone -> Maybe Scale+tone_scale = fmap note_scale . tone_note++tone_pitch :: Tone -> Maybe Pitch+tone_pitch = fmap note_pitch . tone_note++tone_degree :: Tone -> Maybe Degree+tone_degree = fmap pitch_degree . tone_pitch++tone_degree' :: Tone -> Degree+tone_degree' = fromJust_err "tone_degree" . tone_degree++tone_octave :: Tone -> Maybe Octave+tone_octave = fmap pitch_octave . tone_pitch++tone_class :: Tone -> (Instrument_Name,Maybe Scale)+tone_class t = (tone_instrument_name t,tone_scale t)++instrument_class :: Instrument -> (Instrument_Name,Maybe Scale)+instrument_class i = (instrument_name i,instrument_scale i)++tone_class_p :: (Instrument_Name, Scale) -> Tone -> Bool+tone_class_p (nm,sc) t =+    tone_instrument_name t == nm &&+    tone_scale t == Just sc++tone_family_class_p :: (Instrument_Family,Scale) -> Tone -> Bool+tone_family_class_p (fm,sc) t =+    instrument_family (tone_instrument_name t) == Just fm &&+    tone_scale t == Just sc++-- | Given a 'Tone_Set', find those 'Tone's that are within 'T.Cents' of 'Frequency'.+tone_set_near_frequency :: Tone_Set -> T.Cents -> Frequency -> Tone_Set+tone_set_near_frequency t k n =+    let near i = abs (T.cps_difference_cents i n) <= k+        near_t i = maybe False near (tone_frequency i)+    in filter near_t t++-- | Compare 'Tone's by frequency.  'Tone's without frequency compare+-- as if at frequency @0@.+tone_compare_frequency :: Tone -> Tone -> Ordering+tone_compare_frequency = compare `on` (maybe 0 id . tone_frequency)++-- | If all /f/ of /a/ are 'Just' /b/, then 'Just' /[b]/, else+-- 'Nothing'.+map_maybe_uniform :: (a -> Maybe b) -> [a] -> Maybe [b]+map_maybe_uniform f x =+    let x' = map f x+    in if any isNothing x' then Nothing else Just (catMaybes x')++instrument :: Tone_Set -> Instrument+instrument c =+    let sf = fmap note_scale . tone_note+        pf = fmap note_pitch . tone_note+        pm = map_maybe_uniform pf c+        fm = map_maybe_uniform tone_frequency c+        (p,f) = case (pm,fm) of+                  (Just i,Just j) -> let (i',j') = unzip (sort (zip i j))+                                     in (Just i',Just j')+                  _ -> (pm,fm)+    in case c of+         t:_ -> Instrument (tone_instrument_name t) (sf t) p f+         [] -> undefined++instruments :: Tone_Set -> [Instrument]+instruments c =+    let c' = sortBy (compare `on` tone_instrument_name) c+        c'' = groupBy ((==) `on` tone_class) c'+    in map instrument c''++instrument_gamut :: Instrument -> Maybe (Pitch,Pitch)+instrument_gamut =+    let f p = (head p,last p)+    in fmap f . instrument_pitches++scale_degrees :: Scale -> [Degree]+scale_degrees s =+    case s of+      Pelog -> [1..7]+      Slendro -> [1,2,3,5,6]++-- > degree_index Slendro 4 == Nothing+-- > degree_index Pelog 4 == Just 3+degree_index :: Scale -> Degree -> Maybe Int+degree_index s d = findIndex (== d) (scale_degrees s)++-- * Tone set++tone_set_gamut :: Tone_Set -> Maybe (Pitch,Pitch)+tone_set_gamut g =+    case mapMaybe (fmap note_pitch . tone_note) g of+      [] -> Nothing+      p -> Just (minimum p,maximum p)++tone_set_instrument :: Tone_Set -> (Instrument_Name,Maybe Scale) -> Tone_Set+tone_set_instrument db (i,s) =+    let f t = tone_class t == (i,s)+    in filter f db

@@ -0,0 +1,131 @@+-- | Geometrical Drawings+--+-- A. Bernard Deacon and Camilla H. Wedgwood. “Geometrical Drawings+-- from Malekula and Other Islands of the New Hebrides”. The Journal+-- of the Royal Anthropological Institute of Great Britain and+-- Ireland, 64:129—175, 1934.+module Music.Theory.Graph.Deacon_1934 where++import Data.List {- base -}++import qualified Music.Theory.Array.Cell_Ref as T {- hmt -}+import qualified Music.Theory.Array.Direction as T {- hmt -}+import qualified Music.Theory.Graph.Dot as T {- hmt -}+import qualified Music.Theory.Graph.FGL as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Tuple as T {- hmt -}++gen_graph :: Ord v => [T.DOT_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]+gen_graph opt pp es = T.g_to_udot opt pp (T.g_from_edges_l es)++gen_graph_ul :: Ord v => [T.DOT_ATTR] -> (v -> String) -> [T.EDGE v] -> [String]+gen_graph_ul opt pp es = T.g_to_udot opt (T.gr_pp_lift_node_f pp) (T.g_from_edges es)++gen_digraph :: Ord v => [T.DOT_ATTR] -> T.GR_PP v e -> [T.EDGE_L v e] -> [String]+gen_digraph opt pp es = T.g_to_dot T.G_DIGRAPH opt pp Nothing (T.g_from_edges_l es)++type G = (T.GRAPH String,[T.DOT_ATTR],FilePath)++-- * E+g1 :: G+g1 =+    let c1 = words "A1 B2 A3 B4 C3 B2 C1 D2 C3 D4 D3 D2 D1 C2 D3 C4 B3 C2 B1 A2 B3 A4 A3 A2 A1"+        o1 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]+    in (T.adj2 1 c1,o1,"E")++-- * D+g2 :: G+g2 =+    let c2' = words "B3 C2 = C3 B2 A1 = A2 B1 C2 = C1 B2 A3 = A2 B3 C3 C2 B2 B3 ~ C3 ~ C2 C1 == C3 C2 C1 B1 B2 C2 ~ C1 ~ B1 A1 C1 B1 A1 A2 B2 B1 ~ A1 ~ A2 A3 == A1 A2 A3 B3 B2 A2 ~ A3 ~ B3 C3 C3 ~~ C1 ~~ A1 ~~ A3 A3 B3"+        c2 = filter T.is_cell_ref c2'+        o2 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")]+    in (T.adj2 1 c2,o2,"D")++-- * A+g4 :: G+g4 =+    let c4' = words "B1 C2 C3 B3 B2 C2 ~~ C3 C2 ~~ C1 C2 C2 B3 A3 A2 B2 B3 ~~ A3 B3 ~~ C3 B3 B3 A2 A1 B1 B2 A2 ~~ A1 A2 ~~ A3 A2 A2 B1 C1 C2 B2 B1 ~~ C1 B1 ~~ A1 B1 B1"+        c4 = filter T.is_cell_ref c4'+        o4 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")]+    in (T.adj2 1 c4,o4,"A")++g6 :: G+g6 =+    let c6' = words "B1 C2 B2 C1 B1 A2 B2 A1 B1 B2 B3 B3 B3 B3 B2 B1 B0 B0 B0 B0 B1 C1 ~~~ C2 B2 B2 B2 A2 ~~~ A1 B1 B1 B1"+        c6 = filter T.is_cell_ref c6'+        o6 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")]+    in (T.adj2 1 c6,o6,"B")++g8 :: G+g8 =+    let c8' = words "C2 B1 B1 A2 ~ (04) B1 B2 B3 ~ (08) C2 B3 B3 A2 ~ (13) B3 B2 A2 (17) A3 A3 B2 C1 C1 C2 B2 B1 ~ (23) C2 B2 A2 A1 A1 B2 C3 C3 C2"+        c8 = filter T.is_cell_ref c8'+        o8 = [("node:shape","circle"),("edge:len","3"),("edge:fontsize","7")]+    in (T.adj2 1 c8,o8,"C")++g9 :: G+g9 =+    let d9' = ("E6",words "U R D LL (03/D6) U R R U L D D LL (11/C6) U R R U U R D L L D D LL (22/B6) U R R U U R R U L D D L L D D LL (38/A6) U R R U U R R U U R D L L D D L L D D LUU (56/A4) R R U U R R U L D D L L D D L UU (71/A3) R R U U R D L L D D L UU (83/A2) R R U L D D L UU (91/A1) R D L")+        d9 = (fst d9',filter T.is_direction (snd d9'))+        c9 = T.dir_seq_to_cell_seq d9+        o9 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]+    in (T.adj2 1 c9,o9,"F")++g10 :: G+g10 =+    let d10' = ("B7",words "U R LL (03/A6) R R U L D D LUU (10/A5) R R U L D D L UU (18/A4) R R U L D D L UU (26/A3) R R U L D D L UU (34/A2) R R U L D D L UU (41/A1) R D L")+        d10 = (fst d10',filter T.is_direction (snd d10'))+        c10 = T.dir_seq_to_cell_seq d10+        e10 = T.adj2 1 c10+        o10 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]+    in (e10,o10,"G")++g11 :: G+g11 =+    let d11' = ("C3",words "DR DDL UUR U L (05/C3) DL DDR UUL U R (10/C3) D D U UL UUR DDL (16/B3) DL R U (18/B3) L DR R (21/C4) UR UUL DDR DR L (26/D4) U R DL L U (31/C3) U D (33/C3) R UUR DDDDD UUL L . (40/C4) L DDL UUUUU DDR R (44/C3)")+        d11 = (fst d11',filter T.is_direction (snd d11'))+        c11 = T.dir_seq_to_cell_seq d11+        e11 = T.adj2 1 c11+        o11 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]+    in (e11,o11,"H")++g12 :: G+g12 =+    let d12' = ("C2",words "DR UR (02/E2) L DL UL L (06/A2) DR UR UR DR (10/E2) L UL DL L (14/A2) UR DR (16/C2)")+        d12 = (fst d12',filter T.is_direction (snd d12'))+        c12 = T.dir_seq_to_cell_seq d12+        e12 = T.adj2 1 c12+        o12 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]+    in (e12,o12,"I")++g13 :: G+g13 =+    let d13' = ("B3",words "U D D U R DDL UUL R (07/C3) R UU DDL L UU DDR (11/C3)")+        d13 = (fst d13',filter T.is_direction (snd d13'))+        c13 = T.dir_seq_to_cell_seq d13+        e13 = T.adj2 1 c13+        o13 = [("node:shape","circle"),("edge:len","1.5"),("edge:fontsize","7")]+    in (e13,o13,"J")++g_all :: [G]+g_all = [g1,g2,g4,g6,g8,g9,g10,g11,g12,g13]++-- G = unlabeled, GL = labeled+-- GC = collated, GF = filtered (unique edges)+-- GD = directed+wr :: G -> IO ()+wr (e,o,nm) = do+  let mk_nm ty = "/home/rohan/sw/hmt/data/dot/deacon/" ++ nm ++ "_" ++ ty ++ ".dot"+      wr_f ty g = writeFile (mk_nm ty) (unlines g)+  wr_f "G" (gen_graph_ul o id e)+  wr_f "GL" (gen_graph o T.gr_pp_id_show (T.e_label_seq e))+  wr_f "GC" (gen_graph o T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e)))+  wr_f "GF" (gen_graph_ul o id (nub (map T.t2_sort e)))+  wr_f "GD" (gen_digraph o T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e)))+{-+  let o' = ("graph:layout","fdp") : o+  wr_f "GC_" (gen_graph o' T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e)))+-}++wr_all :: IO ()+wr_all = mapM_ wr g_all

@@ -0,0 +1,131 @@+-- | Graph (dot) functions.+module Music.Theory.Graph.Dot where++import Data.Char {- base -}+import Data.List {- base -}++import qualified Data.Graph.Inductive.Graph as G {- fgl -}+import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -}++import qualified Music.Theory.List as T {- hmt -}++-- * UTIL++-- | Separate at element.+--+-- > sep1 ':' "graph:layout"+sep1 :: Eq t => t -> [t] -> ([t],[t])+sep1 e l =+    case break (== e) l of+      (p,_:q) -> (p,q)+      _ -> error "sep1"++-- | Quote /s/ if it includes white space.+--+-- > map maybe_quote ["abc","a b c"] == ["abc","\"a b c\""]+maybe_quote :: String -> String+maybe_quote s = if any isSpace s then concat ["\"",s,"\""] else s++-- | Left biased union of association lists /p/ and /q/.+--+-- > assoc_union [(5,"a"),(3,"b")] [(5,"A"),(7,"C")] == [(5,"a"),(3,"b"),(7,"C")]+assoc_union :: Eq k => [(k,v)] -> [(k,v)] -> [(k,v)]+assoc_union p q =+    let p_k = map fst p+        q' = filter ((`notElem` p_k) . fst) q+    in p ++ q'++-- * ATTR++-- | area:opt (area = graph|node|edge)+type DOT_KEY = String+type DOT_OPT = String+type DOT_VALUE = String+type DOT_ATTR = (DOT_OPT,DOT_VALUE)+type DOT_ATTR_SET = (String,[DOT_ATTR])++-- > dot_key_sep "graph:layout"+dot_key_sep :: String -> (String,String)+dot_key_sep = sep1 ':'++dot_attr_pp :: DOT_ATTR -> String+dot_attr_pp (lhs,rhs) = concat [lhs,"=",maybe_quote rhs]++dot_attr_set_pp :: DOT_ATTR_SET -> String+dot_attr_set_pp (ty,opt) = concat [ty," [",intercalate "," (map dot_attr_pp opt),"];"]++dot_attr_collate :: [DOT_ATTR] -> [DOT_ATTR_SET]+dot_attr_collate opt =+    let f (k,v) = let (ty,nm) = dot_key_sep k in (ty,(nm,v))+        c = map f opt+    in T.collate c++dot_attr_ext :: [DOT_ATTR] -> [DOT_ATTR] -> [DOT_ATTR]+dot_attr_ext = assoc_union++-- > map dot_attr_set_pp (dot_attr_collate dot_attr_def)+dot_attr_def :: [DOT_ATTR]+dot_attr_def =+    [("graph:layout","neato")+    ,("graph:epsilon","0.000001")+    ,("node:shape","plaintext")+    ,("node:fontsize","10")+    ,("node:fontname","century schoolbook")]++-- * GRAPH++-- | Graph pretty-printer, (node->shape,node->label,edge->label)+type GR_PP v e = (v -> Maybe String,v -> Maybe String,e -> Maybe String)++gr_pp_lift_node_f :: (v -> String) -> GR_PP v e+gr_pp_lift_node_f f = (const Nothing, Just . f, const Nothing)++gr_pp_id_show :: Show e => GR_PP String e+gr_pp_id_show = (const Nothing,Just . id,Just . show)++-- | br = brace, csl = comma separated list+br_csl_pp :: Show t => [t] -> String+br_csl_pp l =+    case l of+      [e] -> show e+      _ -> T.bracket ('{','}') (intercalate "," (map show l))++gr_pp_id_br_csl :: Show e => GR_PP String [e]+gr_pp_id_br_csl = (const Nothing,Just . id,Just . br_csl_pp)++-- | Graph type, directed or un-directed.+data G_TYPE = G_DIGRAPH | G_UGRAPH++g_type_to_string :: G_TYPE -> String+g_type_to_string ty =+    case ty of+      G_DIGRAPH -> "digraph"+      G_UGRAPH -> "graph"++g_type_to_edge_symbol :: G_TYPE -> String+g_type_to_edge_symbol ty =+    case ty of+      G_DIGRAPH -> " -> "+      G_UGRAPH -> " -- "++-- | Vertex position function.+type POS_FN v = (v -> (Int,Int))++g_to_dot :: G_TYPE -> [DOT_ATTR] -> GR_PP v e -> Maybe (POS_FN v) -> G.Gr v e -> [String]+g_to_dot g_typ opt (n_sh,n_pp,e_pp) pos_f gr =+    let p_f (c,r) = concat [",pos=\"",show (c * 100),",",show (r * 100),"\""]+        l_f p x = concat [" [label=\"",x,"\"",p,"]"]+        n_f (k,n) = let p = maybe "" (\f -> p_f (f n)) pos_f+                        p' = maybe p (\z -> p ++ ",shape=\"" ++ z ++ "\"") (n_sh n)+                        a = maybe "" (l_f p') (n_pp n)+                    in concat [show k,a,";"]+        e_f (lhs,rhs,e) = let l = maybe "" (l_f "") (e_pp e)+                          in concat [show lhs,g_type_to_edge_symbol g_typ,show rhs,l,";"]+    in concat [[g_type_to_string g_typ," g {"]+              ,map dot_attr_set_pp (dot_attr_collate (assoc_union opt dot_attr_def))+              ,map n_f (G.labNodes gr)+              ,map e_f (G.labEdges gr)+              ,["}"]]++g_to_udot :: [DOT_ATTR] -> GR_PP v e -> G.Gr v e -> [String]+g_to_udot o pp = g_to_dot G_UGRAPH o pp Nothing

@@ -0,0 +1,141 @@+-- | Graph (fgl) functions.+module Music.Theory.Graph.FGL where++import Data.List {- base -}+import Data.Maybe {- base -}++import qualified Data.Map as M {- containers -}++import qualified Data.Graph.Inductive.Graph as G {- fgl -}+import qualified Data.Graph.Inductive.Query as G {- fgl -}+import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -}++import qualified Control.Monad.Logic as L {- logict -}++import qualified Music.Theory.List as T {- hmt -}++-- | Synonym for 'G.noNodes'.+g_degree :: G.Gr v e -> Int+g_degree = G.noNodes++-- | 'G.subgraph' of each of 'G.components'.+g_partition :: G.Gr v e -> [G.Gr v e]+g_partition gr = map (\n -> G.subgraph n gr) (G.components gr)++-- | Find first 'G.Node' with given label.+g_node_lookup :: (Eq v,G.Graph gr) => gr v e -> v -> Maybe G.Node+g_node_lookup gr l = fmap fst (find ((== l) . snd) (G.labNodes gr))++-- | Erroring variant.+g_node_lookup_err :: (Eq v,G.Graph gr) => gr v e -> v -> G.Node+g_node_lookup_err gr = fromMaybe (error "g_node_lookup") . g_node_lookup gr++-- | Set of nodes with given labels, plus all neighbours of these nodes.+-- (impl = implications)+ug_node_set_impl :: (Eq v,G.DynGraph gr) => gr v e -> [v] -> [G.Node]+ug_node_set_impl gr nl =+    let n = map (g_node_lookup_err gr) nl+    in nub (sort (n ++ concatMap (G.neighbors gr) n))++-- * Hamiltonian++type G_NODE_SEL_F v e = G.Gr v e -> G.Node -> [G.Node]++-- | 'L.msum' '.' 'map' 'return'.+ml_from_list :: L.MonadLogic m => [t] -> m t+ml_from_list = L.msum . map return++-- | Use /sel_f/ of 'G.pre' for directed graphs and 'G.neighbors' for undirected.+g_hamiltonian_path_ml :: L.MonadLogic m => G_NODE_SEL_F v e -> G.Gr v e -> G.Node -> m [G.Node]+g_hamiltonian_path_ml sel_f gr =+    let n_deg = g_degree gr+        recur r c =+            if length r == n_deg - 1+            then return (c:r)+            else do i <- ml_from_list (sel_f gr c)+                    L.guard (i `notElem` r)+                    recur (c:r) i+    in recur []++-- > map (L.observeAll . ug_hamiltonian_path_ml_0) (g_partition gr)+ug_hamiltonian_path_ml_0 :: L.MonadLogic m => G.Gr v e -> m [G.Node]+ug_hamiltonian_path_ml_0 gr = g_hamiltonian_path_ml G.neighbors gr (G.nodes gr !! 0)++-- * G (from edges)++-- | Edge, no label.+type EDGE v = (v,v)++-- | Graph as set of edges.+type GRAPH v = [EDGE v]++-- | Edge, with label.+type EDGE_L v l = (EDGE v,l)++-- | Graph as set of labeled edges.+type GRAPH_L v l = [EDGE_L v l]++-- | Generate a graph given a set of labelled edges.+g_from_edges_l :: (Eq v,Ord v) => GRAPH_L v e -> G.Gr v e+g_from_edges_l e =+    let n = nub (concatMap (\((lhs,rhs),_) -> [lhs,rhs]) e)+        n_deg = length n+        n_id = [0 .. n_deg - 1]+        m = M.fromList (zip n n_id)+        m_get k = M.findWithDefault (error "g_from_edges: m_get") k m+        e' = map (\((lhs,rhs),label) -> (m_get lhs,m_get rhs,label)) e+    in G.mkGraph (zip n_id n) e'++-- | Variant that supplies '()' as the (constant) edge label.+--+-- > let g = G.mkGraph [(0,'a'),(1,'b'),(2,'c')] [(0,1,()),(1,2,())]+-- > in g_from_edges_ul [('a','b'),('b','c')] == g+g_from_edges :: Ord v => GRAPH v -> G.Gr v ()+g_from_edges = let f e = (e,()) in g_from_edges_l . map f++-- * Edges++-- | Label sequence of edges starting at one.+e_label_seq :: [EDGE v] -> [EDGE_L v Int]+e_label_seq = map (\(k,e) -> (e,k)) . zip [1..]++-- | Normalised undirected labeled edge (ie. order nodes).+e_normalise_l :: Ord v => EDGE_L v l -> EDGE_L v l+e_normalise_l ((p,q),r) = ((min p q,max p q),r)++-- | Collate labels for edges that are otherwise equal.+e_collate_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]]+e_collate_l = T.collate++-- | 'e_collate_l' of 'e_normalise_l'.+e_collate_normalised_l :: Ord v => [EDGE_L v l] -> [EDGE_L v [l]]+e_collate_normalised_l = e_collate_l . map e_normalise_l++-- | Apply predicate to universe of possible edges.+e_univ_select_edges :: (t -> t -> Bool) -> [t] -> [EDGE t]+e_univ_select_edges f l = [(p,q) | p <- l, q <- l, f p q]++-- | Consider only edges (p,q) where p < q.+e_univ_select_u_edges :: Ord t => (t -> t -> Bool) -> [t] -> [EDGE t]+e_univ_select_u_edges f = let g p q = p < q && f p q in e_univ_select_edges g++-- | Sequence of connected vertices to edges.+--+-- > e_path_to_edges "abcd" == [('a','b'),('b','c'),('c','d')]+e_path_to_edges :: [t] -> [EDGE t]+e_path_to_edges = T.adj2 1++-- | Undirected edge equality.+e_undirected_eq :: Eq t => EDGE t -> EDGE t -> Bool+e_undirected_eq (a,b) (c,d) = (a == c && b == d) || (a == d && b == c)++elem_by :: (p -> q -> Bool) -> p -> [q] -> Bool+elem_by f = any . f++-- | Is the sequence of vertices a path at the graph, ie. are all+-- adjacencies in the sequence edges.+e_is_path :: Eq t => GRAPH t -> [t] -> Bool+e_is_path e sq =+    case sq of+      p:q:sq' -> elem_by e_undirected_eq (p,q) e && e_is_path e (q:sq')+      _ -> True

@@ -0,0 +1,290 @@+-- | Tom Johnson. /Other Harmony: Beyond Tonal and Atonal/. Editions 75, 2014.+module Music.Theory.Graph.Johnson_2014 where++import Control.Monad {- base -}+import Data.List {- base -}+import qualified Data.Map as M {- containers -}+import Data.Maybe {- base -}++import qualified Music.Theory.Combinations as T {- hmt -}+import qualified Music.Theory.Graph.Dot as T {- hmt -}+import qualified Music.Theory.Graph.FGL as T {- hmt -}+import qualified Music.Theory.Key as T {- hmt -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Pitch.Note as T {- hmt -}+import qualified Music.Theory.Tuning as T {- hmt -}+import qualified Music.Theory.Tuning.Euler as T {- hmt -}+import qualified Music.Theory.Z.SRO as T {- hmt -}++-- * Common++type Z12 = Int++mod12 :: Integral a => a -> a+mod12 n = n `mod` 12++dif :: Num a => (a, a) -> a+dif = uncurry (-)++absdif :: Num a => (a, a) -> a+absdif = abs . dif++-- | interval (0,11) to interval class (0,6)+i_to_ic :: (Num a, Ord a) => a -> a+i_to_ic n = if n > 6 then 12 - n else n++p2_and :: (t -> u -> Bool) -> (t -> u -> Bool) -> t -> u -> Bool+p2_and p q i j = p i j && q i j++-- | degree of intersection+doi :: Eq t => [t] -> [t] -> Int+doi p = length . intersect p++doi_of :: Eq t => Int -> [t] -> [t] -> Bool+doi_of n p = (==) n . doi p++-- | The sum of the pointwise absolute difference.+loc_dif :: Num t => [t] -> [t] -> t+loc_dif p q = let f i j = abs (i - j) in sum (zipWith f p q)++loc_dif_of :: (Eq t, Num t) => t -> [t] -> [t] -> Bool+loc_dif_of n p q = loc_dif p q == n++loc_dif_in :: (Eq t, Num t) => [t] -> [t] -> [t] -> Bool+loc_dif_in n p q = loc_dif p q `elem` n++-- | The number of places that are, pointwise, not equal.+--+-- > loc_dif_n "test" "pest" == 1+loc_dif_n :: (Eq t,Num i) => [t] -> [t] -> i+loc_dif_n p q =+    let f i j = if i == j then 0 else 1+    in sum (zipWith f p q)++loc_dif_n_of :: Eq t => Int -> [t] -> [t] -> Bool+loc_dif_n_of n p q = loc_dif_n p q == n++-- > min_vl [6,11,13] [6,10,14] == 2+min_vl :: (Num a,Ord a) => [a] -> [a] -> a+min_vl p q =+    let f x = sum (map absdif (zip p x))+    in minimum (map f (permutations q))++min_vl_of :: (Num a, Ord a) => a -> [a] -> [a] -> Bool+min_vl_of n p q = min_vl p q == n++min_vl_in :: (Num a, Ord a) => [a] -> [a] -> [a] -> Bool+min_vl_in n p q = min_vl p q `elem` n++combinations2 :: Ord t => [t] -> [(t, t)]+combinations2 p = [(i,j) | i <- p, j <- p, i < j]++set_pp :: Show t => [t] -> String+set_pp = intercalate "," . map show++-- * Map++m_get :: Ord k => M.Map k v -> k -> v+m_get m i = fromMaybe (error "get") (M.lookup i m)++-- | degree of intersection+m_doi_of :: M.Map Int [Z12] -> Int -> Int -> Int -> Bool+m_doi_of m n p q = doi_of n (m_get m p) (m_get m q)++-- * Graph++gen_graph_ul :: Ord v => [T.DOT_ATTR] -> (v -> String) -> [T.EDGE v] -> [String]+gen_graph_ul opt pp es = T.g_to_udot opt (T.gr_pp_lift_node_f pp) (T.g_from_edges es)++gen_graph_ul_ty :: Ord v => String -> (v -> String) -> [T.EDGE v] -> [String]+gen_graph_ul_ty ty = gen_graph_ul [("graph:layout",ty)]++gen_flt_graph :: (Ord t, Show t) => [T.DOT_ATTR] -> ([t] -> [t] -> Bool) -> [[t]] -> [String]+gen_flt_graph o f p = gen_graph_ul o set_pp (T.e_univ_select_u_edges f p)++-- * P.12++-- | <http://localhost/rd/?t=j&e=2016-04-04.md>+p12_euler_plane :: T.Euler_Plane Rational+p12_euler_plane =+    let f = T.fold_ratio_to_octave_err+        l1 = T.tun_seq 4 (3/2) (f (1 * 2/3 * 5/4))+        l2 = T.tun_seq 5 (3/2) (f (1 * 2/3 * 2/3))+        l3 = T.tun_seq 3 (3/2) (f (1 * 2/3 * 4/5))+        (c1,c2) = T.euler_align_rat (5/4,5/4) (l1,l2,l3)+    in ([l1,l2,l3],c1 ++ c2)++p12_euler_plane_gr :: [String]+p12_euler_plane_gr = T.euler_plane_to_dot_rat (0,True) p12_euler_plane++-- * P.14++p14_edges :: [(T.Key,T.Key)]+p14_edges =+    let univ = [0::Int .. 11]+        trs n = map (mod12 . (+ n))+        e_par = zip univ univ+        e_rel = zip univ (trs 9 univ)+        e_med = zip univ (trs 4 univ)+        del_par = [10]+        del_rel = [5,6]+        del_med = [2,5,8,11]+        rem_set r = filter (\(lhs,_) -> lhs `notElem` r)+        pc_to_key m pc = let Just (n,a) = T.pc_to_note_alteration_ks pc in (n,a,m)+        e_lift (lhs,rhs) = (pc_to_key T.Major_Mode lhs,pc_to_key T.Minor_Mode rhs)+        e_mod = concat [rem_set del_par e_par,rem_set del_rel e_rel,rem_set del_med e_med]+    in map e_lift e_mod++p14_gr :: [String]+p14_gr =+    let opt = [("graph:start","168732")]+        pp = T.gr_pp_lift_node_f T.key_lc_uc_pp+        gr = T.g_from_edges p14_edges+    in T.g_to_udot opt pp gr++-- * P.31++p31_f_4_22 :: [Z12]+p31_f_4_22 = [0,2,4,7]++p31_e_set :: [([Z12],[Z12])]+p31_e_set = T.e_univ_select_u_edges (doi_of 3) (map sort (T.z_sro_ti_related mod12 p31_f_4_22))++p31_gr :: [String]+p31_gr = gen_graph_ul [] set_pp p31_e_set++-- * P.114++p114_f_3_7 :: [Z12]+p114_f_3_7 = [0,2,5]++p114_mk_gr :: Double -> ([Z12] -> [Z12] -> Bool) -> [String]+p114_mk_gr el flt =+    let o = [("node:shape","box")+            ,("edge:len",show el)]+    in gen_flt_graph o flt (map sort (T.z_sro_ti_related mod12 p114_f_3_7))++p114_gr_set :: [(String,[String])]+p114_gr_set =+  [("p114.1.dot",p114_mk_gr 2.5 (doi_of 2))+  ,("p114.2.dot"+   ,let o = [("edge:len","1.25")]+    in gen_flt_graph o (loc_dif_of 1) (T.combinations 3 [1::Int .. 6]))+  ,("p114.3.dot",p114_mk_gr 1.5 (loc_dif_n_of 1))+  ,("p114.4.dot",p114_mk_gr 1.5 (loc_dif_of 1))+  ,("p114.5.dot",p114_mk_gr 1.5 (loc_dif_of 2))+  ,("p114.6.dot",p114_mk_gr 1.5 (loc_dif_in [1,2]))+  ,("p114.7.dot",p114_mk_gr 1.5 (loc_dif_in [1,2,3]))+  ,("p114.8.dot",p114_mk_gr 1.5 (min_vl_in [1,2,3]))+  ,("p114.9.dot",p114_mk_gr 2.0 (min_vl_in [1,2,3,4]))+  ]++-- * P.125++p125_gr :: [String]+p125_gr =+    let t :: [[Int]]+        t = [[p,q,r] | p <- [0 .. 11], q <- [0 .. 11], r <- [0 ..11], q > p, r > q]+        c = T.collate (zip (map sum t) t)+        with_h n = lookup n c+        ch = fromJust (liftM2 (++) (with_h 15) (with_h 16))+    in gen_graph_ul [] set_pp (T.e_univ_select_u_edges (doi_of 2) ch)++-- * P.131++p131_gr :: [String]+p131_gr =+    let c = let u = [6::Int .. 14]+            in [[p,q,r] | p <- u, q <- u, r <- u, q > p, r > q, p + q + r == 30]+    in gen_graph_ul [] set_pp (T.e_univ_select_u_edges (min_vl_of 2) c)++-- * P.148++p148_mk_gr :: ([Int] -> [Int] -> Bool) -> [String]+p148_mk_gr f =+    let mid_set_pp :: [Int] -> String+        mid_set_pp = concatMap show . take 3 . drop 1+        i_seq :: Num i => [[i]]+        i_seq = permutations [1,2,3,4]+        p_seq :: (Ord i,Num i) => [[i]]+        p_seq = sort (map (T.dx_d 0) i_seq)+    in gen_graph_ul [("edge:len","1.75")] mid_set_pp (T.e_univ_select_u_edges f p_seq)++p148_gr_set :: [(String,[String])]+p148_gr_set =+  [("p148.0.dot",p148_mk_gr (doi_of 4))+  ,("p148.1.dot",p148_mk_gr (min_vl_in [1]))+  ,("p148.2.dot",p148_mk_gr (min_vl_in [1,2]))+  ,("p148.3.dot",p148_mk_gr (p2_and (doi_of 4) (min_vl_in [1])))+  ,("p148.4.dot",p148_mk_gr (p2_and (doi_of 4) (min_vl_in [1,2])))+  ,("p148.5.dot",p148_mk_gr (loc_dif_n_of 1))+  ,("p148.6.dot",p148_mk_gr (loc_dif_of 1))+  ]++-- * P.162++p162_gr :: [String]+p162_gr =+    let n = [0::Int,1,2,3,4,5,6,7,8]+        c = T.combinations 4 n+        ch = filter ((== 1) . (`mod` 4) . sum) c+        opt = [("graph:layout","neato")+              ,("edge:len","1.75")]+    in gen_graph_ul opt set_pp (T.e_univ_select_u_edges (doi_of 3) ch)++-- * P.172++p172_nd_map :: M.Map Int [Z12]+p172_nd_map =+    let nd_exp = map sort (T.z_sro_ti_related mod12 [0,1,3,7])+    in M.fromList (zip [0..] nd_exp)++p172_set_pp :: Int -> String+p172_set_pp = set_pp . m_get p172_nd_map++p172_gr_set :: [(String,[String])]+p172_gr_set =+    [("p172.0.dot"+     ,let nd_e_set = T.e_univ_select_u_edges (m_doi_of p172_nd_map 0) [0..23]+      in gen_graph_ul_ty "circo" p172_set_pp nd_e_set)+    ,("p172.1.dot"+     ,let nd_e_set = concatMap T.e_path_to_edges+                     [[22,11,20,9,18,7,16,5,14,3,12,1,22]+                     ,[23,2,13,8,19,10,21,4,15,6,17,0,23]]+      in gen_graph_ul_ty "circo" p172_set_pp nd_e_set)]++-- * P.177++-- > map (partition_ic 4) p_set+-- > map (partition_ic 6) p_set+partition_ic :: (Num t, Ord t, Show t) => t -> [t] -> ([t], [t])+partition_ic n p =+    case find ((== n) . i_to_ic . absdif) (combinations2 p) of+      Just (i,j) -> let q = sort [i,j] in (q,sort (p \\ q))+      Nothing -> error (show ("partition_ic",n,p))++p177_gr_set :: [(String,[String])]+p177_gr_set =+    let p_set = concatMap (T.z_sro_ti_related mod12) [[0::Int,1,4,6],[0,1,3,7]]+    in [("p177.0.dot",gen_graph_ul [] set_pp (map (partition_ic 4) p_set))+       ,("p177.1.dot",gen_graph_ul_ty "circo" set_pp (map (partition_ic 6) p_set))+       ,("p177.2.dot"+        ,let gr_pp = T.gr_pp_lift_node_f set_pp+             gr = T.g_from_edges (map (partition_ic 6) p_set)+         in T.g_to_udot [("edge:len","1.5")] gr_pp gr)]++-- * IO++wr_graphs :: IO ()+wr_graphs = do+  let f (nm,gr) = writeFile ("/home/rohan/sw/hmt/data/dot/tj_oh_" ++ nm) (unlines gr)+  f ("p012.dot",p12_euler_plane_gr)+  f ("p014.dot",p14_gr)+  f ("p031.dot",p31_gr)+  mapM_ f p114_gr_set+  f ("p125.dot",p125_gr)+  f ("p131.dot",p131_gr)+  mapM_ f p148_gr_set+  f ("p162.dot",p162_gr)+  mapM_ f p172_gr_set+  mapM_ f p177_gr_set

@@ -0,0 +1,34 @@+-- | "System.IO" related functions.+module Music.Theory.IO where++import qualified Data.ByteString as B {- bytestring -}+import qualified Data.Text as T {- text -}+import qualified Data.Text.Encoding as T {- text -}+import qualified Data.Text.IO as T {- text -}+import qualified System.Directory as D {- directory -}++-- | 'T.decodeUtf8' of 'B.readFile'.+read_file_utf8_text :: FilePath -> IO T.Text+read_file_utf8_text = fmap T.decodeUtf8 . B.readFile++-- | Read (strictly) a UTF-8 encoded text file, implemented via "Data.Text".+read_file_utf8 :: FilePath -> IO String+read_file_utf8 = fmap T.unpack . read_file_utf8_text++-- | 'read_file_utf8', or a default value if the file doesn't exist.+read_file_utf8_or :: String -> FilePath -> IO String+read_file_utf8_or def f = do+  x <- D.doesFileExist f+  if x then read_file_utf8 f else return def++-- | Write UTF8 string as file, via "Data.Text".+write_file_utf8 :: FilePath -> String -> IO ()+write_file_utf8 fn = B.writeFile fn . T.encodeUtf8 . T.pack++-- | 'readFile' variant using 'Text' for @ISO 8859-1@ (Latin 1) encoding.+read_file_iso_8859_1 :: FilePath -> IO String+read_file_iso_8859_1 = fmap (T.unpack . T.decodeLatin1) . B.readFile++-- | 'readFile' variant using 'Text' for local encoding.+read_file_locale :: FilePath -> IO String+read_file_locale = fmap T.unpack . T.readFile

@@ -0,0 +1,114 @@+module Music.Theory.Instrument.Names where++import Data.List.Split {- split -}++-- (family,abbreviations,names,transpositions)+instrument_db' :: [(String,String,String,String)]+instrument_db' =+    [("br","b.tbn","bass trombone","")+    ,("br","b.tuba","bass tuba","")+    ,("br","euph","euphonium","")+    ,("br","hn","french horn","F")+    ,("br","tbn;trm","trombone","")+    ,("br","tb;tba","tuba","")+    ,("br","tpt","trumpet","B♭")+    ,("br","t.tbn","tenor trombone","")+    ,("br","crt","cornet","")+    ,("br","fgh;flhn","flugel horn","")+    ,("br","p.tpt","piccolo trumpet","")+    ,("el","cd","compact disc","")+    ,("el","el;elec","electronics","")+    ,("el","tp","tape","")+    ,("el","om","ondes martenot","")+    ,("kb","h;hrm","harmonium","")+    ,("kb","e.pf","electric piano","")+    ,("kb","p;pf;pno","piano;pianoforte","")+    ,("kb","o;or;org","organ","")+    ,("kb","kb;kbd","keyboard","")+    ,("kb","cel","celeste","")+    ,("kb","clvd","clavichord","")+    ,("kb","hpd;hpcd","harpsichord","")+    ,("kb","syn","synthesiser","")+    ,("pc","bd","bass drum","")+    ,("pc","btl","bottle","")+    ,("pc","cast","castanets","")+    ,("pc","cbell","cow-bell","")+    ,("pc","bell","bell","chimes")+    ,("pc","clv","clave","")+    ,("pc","crot","crotales","")+    ,("pc","cym","cymbals","")+    ,("pc","dm","drum","")+    ,("pc","gl;glsp","glockenspiel","")+    ,("pc","mcas","maracas","")+    ,("pc","met.bl","metal block","")+    ,("pc","mr;mar","marimba","")+    ,("pc","sd","side drum","")+    ,("pc","sn.dm","snare drum","")+    ,("pc","sus.cym","suspended cymbal","")+    ,("pc","tamb","tambourine","")+    ,("pc","tam","tam tam","")+    ,("pc","t.bells","tubular bells","")+    ,("pc","td","tenor drum","")+    ,("pc","tri;tgl","triangle","")+    ,("pc","tm;timp","timpani","")+    ,("pc","tpl.bl","temple blocks","")+    ,("pc","vb;vib","vibraphone","")+    ,("pc","wdbl","wood block","")+    ,("pc","xyl","xylophone","")+    ,("str","va;vla","viola","")+    ,("str","vc;vlc","cello;violoncello","")+    ,("str","vn;vln","violin","")+    ,("str","cb","contrabass","")+    ,("str","db","double bass","")+    ,("str","vda","viola d'amore","")+    ,("str","b.gtr","bass guitar","")+    ,("str","e.gtr","electric guitar","")+    ,("str","gtr","guitar","")+    ,("str","","lute","")+    ,("str","zith","zither","")+    ,("str","hp","harp","")+    ,("str","dulc","dulcimer","")+    ,("str","mand","mandolin","")+    ,("vc","a;alt","alto","")+    ,("vc","b;bass","bass","")+    ,("vc","mz;mez","mezzo-soprano","")+    ,("vc","n;nar","narrator","")+    ,("vc","s;sop","soprano","")+    ,("vc","t;tn","tenor","")+    ,("vc","v;vc;voc","voice","")+    ,("vc","ch","chorus","")+    ,("vc","ctral","contralto","")+    ,("vc","ctrbs","contrabass","")+    ,("vc","bar","baritone","")+    ,("vc","b.bar","bass baritone","")+    ,("ww","b.cl","bass clarinet","")+    ,("ww","cb.cl","contrabass clarinet","")+    ,("ww","c;cl","clarinet","B♭")+    ,("ww","a.fl","alto flute","G")+    ,("ww","b.fl","bass flute","C")+    ,("ww","bn;bsn","bassoon","")+    ,("ww","f;fl","flute","")+    ,("ww","hb;htb","hautbois","")+    ,("ww","o;ob","oboe","")+    ,("ww","p;picc","piccolo","")+    ,("ww","ca","cor anglais","")+    ,("ww","c.bn","contrabassoon","")+    ,("ww","a.sax","alto saxophone","E♭")+    ,("ww","b.sax","baritone saxophone","E♭")+    ,("ww","b.ob","bass oboe","")+    ,("ww","cfg","contrafagotto","")+    ,("ww","eh;en.hn","english horn","")+    ,("ww","fg","fagotto","")+    ,("ww","rec","recorder","")+    ,("ww","sax","saxophone","")+    ,("ww","s.sax","soprano saxophone","B♭")+    ,("ww","t.sax","tenor saxophone","B♭")+    ,("ww","oca","ocarina","")+    ]++-- (family,[abbreviations],[names],[transpositions])+instrument_db :: [(String,[String],[String],[String])]+instrument_db =+    let sep = splitOn ";"+        f (fm,ab,nm,tr) = (fm,sep ab,sep nm,sep tr)+    in map f instrument_db'

@@ -4,8 +4,9 @@ import Data.List {- base -} import Data.Maybe {- base -} -import Music.Theory.Pitch-import Music.Theory.Pitch.Note+import qualified Music.Theory.Ord as T+import qualified Music.Theory.Pitch as T+import qualified Music.Theory.Pitch.Note as T  -- | Interval type or degree. data Interval_T = Unison | Second | Third | Fourth@@ -24,13 +25,13 @@ data Interval = Interval {interval_type :: Interval_T                          ,interval_quality :: Interval_Q                          ,interval_direction :: Ordering-                         ,interval_octave :: Octave}+                         ,interval_octave :: T.Octave}                 deriving (Eq,Show)  -- | Interval type between 'Note_T' values. -- -- > map (interval_ty C) [E,B] == [Third,Seventh]-interval_ty :: Note_T -> Note_T -> Interval_T+interval_ty :: T.Note_T -> T.Note_T -> Interval_T interval_ty n1 n2 = toEnum ((fromEnum n2 - fromEnum n1) `mod` 7)  -- | Table of interval qualities.  For each 'Interval_T' gives@@ -95,41 +96,17 @@                 in if dir == GT then negate n - o else n + o       Nothing -> error "interval_semitones" --- | Inclusive set of 'Note_T' within indicated interval.  This is not--- equal to 'enumFromTo' which is not circular.------ > note_span E B == [E,F,G,A,B]--- > note_span B D == [B,C,D]--- > enumFromTo B D == []-note_span :: Note_T -> Note_T -> [Note_T]-note_span n1 n2 =-    let fn x = toEnum (x `mod` 7)-        n1' = fromEnum n1-        n2' = fromEnum n2-        n2'' = if n1' > n2' then n2' + 7 else n2'-    in map fn [n1' .. n2'']---- | Invert 'Ordering', ie. 'GT' becomes 'LT' and vice versa.------ > map invert_ordering [LT,EQ,GT] == [GT,EQ,LT]-invert_ordering :: Ordering -> Ordering-invert_ordering x =-    case x of-      LT -> GT-      EQ -> EQ-      GT -> LT- -- | Determine 'Interval' between two 'Pitch'es. -- -- > interval (Pitch C Sharp 4) (Pitch D Flat 4) == Interval Second Diminished EQ 0 -- > interval (Pitch C Sharp 4) (Pitch E Sharp 5) == Interval Third Major LT 1-interval :: Pitch -> Pitch -> Interval+interval :: T.Pitch -> T.Pitch -> Interval interval p1 p2 =     let c = compare p1 p2-        (Pitch n1 _ o1) = p1-        (Pitch n2 _ o2) = p2-        p1' = pitch_to_pc p1-        p2' = pitch_to_pc p2+        (T.Pitch n1 _ o1) = p1+        (T.Pitch n2 _ o2) = p2+        p1' = T.pitch_to_pc p1+        p2' = T.pitch_to_pc p2         st = (p2' - p1') `mod` 12         ty = interval_ty n1 n2         (Just qu) = interval_q ty (fromIntegral st)@@ -138,13 +115,11 @@          GT -> (interval p2 p1) { interval_direction = GT }          _ -> Interval ty qu c (o2 - o1 + o_a) --- | Apply 'invert_ordering' to 'interval_direction' of 'Interval'.+-- | Apply 'T.ord_invert' to 'interval_direction' of 'Interval'. -- -- > invert_interval (Interval Third Major LT 1) == Interval Third Major GT 1 invert_interval :: Interval -> Interval-invert_interval (Interval t qu d o) =-    let d' = invert_ordering d-    in Interval t qu d' o+invert_interval (Interval t qu d o) = Interval t qu (T.ord_invert d) o  -- | The signed difference in semitones between two 'Interval_Q' -- values when applied to the same 'Interval_T'.  Can this be written@@ -185,9 +160,9 @@ -- | Transpose a 'Pitch' by an 'Interval'. -- -- > transpose (Interval Third Diminished LT 0) (Pitch C Sharp 4) == Pitch E Flat 4-pitch_transpose :: Interval -> Pitch -> Pitch+pitch_transpose :: Interval -> T.Pitch -> T.Pitch pitch_transpose i ip =-    let (Pitch p_n p_a p_o) = ip+    let (T.Pitch p_n p_a p_o) = ip         (Interval i_t i_q i_d i_o) = i         i_d' = if i_d == GT                then -1@@ -199,10 +174,10 @@              else if p_n' < p_n && i_d == LT                   then 1                   else 0-        ip' = Pitch p_n' p_a (p_o + i_o + oa)+        ip' = T.Pitch p_n' p_a (p_o + i_o + oa)         st = if i_d == GT-             then (pitch_to_pc ip - pitch_to_pc ip') `mod` 12-             else (pitch_to_pc ip' - pitch_to_pc ip) `mod` 12+             then (T.pitch_to_pc ip - T.pitch_to_pc ip') `mod` 12+             else (T.pitch_to_pc ip' - T.pitch_to_pc ip) `mod` 12         ty = if i_d == GT              then interval_ty p_n' p_n              else interval_ty p_n p_n'@@ -210,14 +185,14 @@              in fromMaybe err (interval_q ty (fromIntegral st))         qd = quality_difference qu i_q * i_d'         p_a' = toEnum (fromEnum p_a + (qd * 2))-    in ip' { alteration = p_a' }+    in ip' {T.alteration = p_a'}  -- | Make leftwards (perfect fourth) and and rightwards (perfect -- fifth) circles from 'Pitch'. -- -- > let c = circle_of_fifths (Pitch F Sharp 4) -- > in map pitch_to_pc (snd c) == [6,1,8,3,10,5,12,7,2,9,4,11]-circle_of_fifths :: Pitch -> ([Pitch], [Pitch])+circle_of_fifths :: T.Pitch -> ([T.Pitch], [T.Pitch]) circle_of_fifths x =     let p4 = Interval Fourth Perfect LT 0         p5 = Interval Fifth Perfect LT 0@@ -228,7 +203,7 @@ -- displacement. -- -- > mapMaybe parse_interval_type (map show [1 .. 15])-parse_interval_type :: String -> Maybe (Interval_T,Octave)+parse_interval_type :: String -> Maybe (Interval_T,T.Octave) parse_interval_type n =     case reads n of       [(n',[])] -> if n' == 0@@ -249,7 +224,7 @@ -- 'parse_interval_type'. -- -- > map interval_type_degree [(Third,0),(Second,1),(Unison,2)] == [3,9,15]-interval_type_degree :: (Interval_T,Octave) -> Int+interval_type_degree :: (Interval_T,T.Octave) -> Int interval_type_degree (t,o) = fromEnum t + 1 + (fromIntegral o * 7)  -- | Inverse of 'parse_interval_quality.@@ -282,6 +257,10 @@          '+':q:n -> f q n          q:n -> f q n          _ -> Nothing++-- | 'error' variant.+parse_interval_err :: String -> Interval+parse_interval_err = fromMaybe (error "parse_interval") . parse_interval  -- | Pretty printer for intervals, inverse of 'parse_interval'. interval_pp :: Interval -> String

@@ -5,12 +5,13 @@  import Data.List {- base -} import Data.Maybe {- base -}-import Data.Numbers.Primes {- primes -} import Data.Ratio {- base -} import Text.Printf {- base -} -import Music.Theory.Tuning+import qualified Data.Numbers.Primes as P {- primes -} +import qualified Music.Theory.Tuning as T {- hmt -}+ -- | Barlow's /indigestibility/ function for prime numbers. -- -- > map barlow [1,2,3,5,7,11,13] == [0,1,8/3,32/5,72/7,200/11,288/13]@@ -22,22 +23,26 @@  -- | Generate list of factors of /n/ from /x/. ----- > factor primes 315 == [3,3,5,7]+-- > factor P.primes 315 == [3,3,5,7]+-- > P.primeFactors 315 == [3,3,5,7] factor :: Integral a => [a] -> a -> [a] factor x n =     case x of       [] -> undefined-      i:x' -> if i * i > n-              then [n]-              else if rem n i == 0-                   then i : factor x (quot n i)-                   else factor x' n+      i:x' -> if n < i+              then [] -- ie. prime factors of 1...+              else if i * i > n+                   then [n]+                   else if rem n i == 0+                        then i : factor x (quot n i)+                        else factor x' n  -- | 'factor' /n/ from 'primes'. ----- > prime_factors 315 == [3,3,5,7]+-- > map prime_factors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]]+-- > map P.primeFactors [1,4,231,315] == [[],[2,2],[3,7,11],[3,3,5,7]] prime_factors :: Integral a => a -> [a]-prime_factors = factor primes+prime_factors = factor P.primes  -- | Collect number of occurences of each element of a sorted list. --@@ -49,11 +54,11 @@                 e:_ -> (e,genericLength x)     in map f . group --- | 'multiplicities' '.' 'prime_factors'.+-- | 'multiplicities' '.' 'P.primeFactors'. -- -- > prime_factors_m 315 == [(3,2),(5,1),(7,1)] prime_factors_m :: Integral a => a -> [(a,a)]-prime_factors_m = multiplicities . prime_factors+prime_factors_m = multiplicities . P.primeFactors  -- | Merging function for 'rational_prime_factors_m'. merge :: (Ord a,Num b,Eq b) => [(a,b)] -> [(a,b)] -> [(a,b)]@@ -91,10 +96,11 @@ -- up to the /n/th prime. -- -- > rational_prime_factors_t 6 (12,7) == [2,1,0,-1,0,0]+-- > rational_prime_factors_t 6 (32,9) == [5,-2,0,0,0,0] rational_prime_factors_t :: Integral b => Int -> (b,b) -> [b] rational_prime_factors_t n x =     let r = rational_prime_factors_m x-    in map (\i -> fromMaybe 0 (lookup i r)) (take n primes)+    in map (\i -> fromMaybe 0 (lookup i r)) (take n P.primes)  -- | Compute the disharmonicity of the interval /(p,q)/ using the -- prime valuation function /pv/.@@ -120,7 +126,7 @@ to_rational = uncurry (%)  -- | Make 'numerator' 'denominator' pair of /n/.-from_rational :: Integral t => Ratio t -> (t, t)+from_rational :: Ratio t -> (t, t) from_rational n = (numerator n,denominator n)  -- | Set of 1. interval size (cents), 2. intervals as product of@@ -130,13 +136,14 @@ -- | Table 2 (p.45) -- -- > length (table_2 0.06) == 24+-- > length (table_2 0.04) == 66 table_2 :: Double -> [Table_2_Row] table_2 z =     let g n = n <= 2 && n >= 1         r = nub (sort (filter g [p % q | p <- [1..81],q <- [1..81]]))         h = map (harmonicity_r barlow) r         f = (> z) . snd-        k (i,j) = (fratio_to_cents i,rational_prime_factors_t 6 (from_rational i),i,j)+        k (i,j) = (T.fratio_to_cents i,rational_prime_factors_t 6 (from_rational i),i,j)     in map k (filter f (zip r h))  -- | Pretty printer for 'Table_2_Row' values.

@@ -1,33 +1,205 @@ -- | Common music keys. module Music.Theory.Key where +import Control.Monad {- base -}+import Data.Char {- base -} import Data.List {- base -}+import Data.Maybe {- base -} -import Music.Theory.Pitch-import Music.Theory.Pitch.Name-import Music.Theory.Pitch.Note-import Music.Theory.Interval+import qualified Music.Theory.List as T+import qualified Music.Theory.Pitch as T+import qualified Music.Theory.Pitch.Name as T+import qualified Music.Theory.Pitch.Note as T+import qualified Music.Theory.Interval as T  -- | Enumeration of common music notation modes. data Mode_T = Minor_Mode | Major_Mode               deriving (Eq,Ord,Show) --- | A common music notation key is a 'Note_T', 'Alteration_T',--- 'Mode_T' triple.-type Key = (Note_T,Alteration_T,Mode_T)+-- | Pretty printer for 'Mode_T'.+mode_pp :: Mode_T -> String+mode_pp m =+    case m of+      Minor_Mode -> "Minor"+      Major_Mode -> "Major" +-- | Lower-cased 'mode_pp'.+mode_identifier_pp :: Mode_T -> String+mode_identifier_pp = map toLower . mode_pp++-- | There are two modes, given one return the other.+mode_parallel :: Mode_T -> Mode_T+mode_parallel m = if m == Minor_Mode then Major_Mode else Minor_Mode++mode_pc_seq :: Num t => Mode_T -> [t]+mode_pc_seq md =+    case md of+      Major_Mode -> [0,2,4,5,7,9,11]+      Minor_Mode -> [0,2,3,5,7,8,10]++-- | A common music notation key is a 'Note_T', 'Alteration_T', 'Mode_T' triple.+type Key = (T.Note_T,T.Alteration_T,Mode_T)++-- | 'Mode_T' of 'Key'.+key_mode :: Key -> Mode_T+key_mode (_,_,m) = m++-- | Enumeration of 42 CMN keys.+--+-- > length key_sequence_42 == 7 * 3 * 2+key_sequence_42 :: [Key]+key_sequence_42 =+    let a_seq = [T.Flat,T.Natural,T.Sharp]+        m_seq = [Major_Mode,Minor_Mode]+    in [(n,a,m) | n <- T.note_seq,a <- a_seq,m <- m_seq]++-- | Subset of 'key_sequence' not including very eccentric keys (where+-- there are more than 7 alterations).+--+-- > length key_sequence_30 == 30+key_sequence_30 :: [Key]+key_sequence_30 = filter (\k -> maybe False ((< 8) . abs) (key_fifths k)) key_sequence_42++-- | Parallel key, ie. 'mode_parallel' of 'Key'.+key_parallel :: Key -> Key+key_parallel (n,a,m) = (n,a,mode_parallel m)++-- | Transposition of 'Key'.+key_transpose :: Key -> Int -> Key+key_transpose (n,a,m) x =+    let Just pc = T.note_alteration_to_pc (n,a)+        Just (n',a') = T.pc_to_note_alteration_ks ((pc + x) `mod` 12)+    in (n',a',m)++-- | Relative key (ie. 'mode_parallel' with the same number of and type of alterations.+--+-- > let k = [(T.C,T.Natural,Major_Mode),(T.E,T.Natural,Minor_Mode)]+-- > in map (key_lc_uc_pp . key_relative) k == ["a♮","G♮"]+key_relative :: Key -> Key+key_relative k =+    case key_mode k of+      Major_Mode -> key_parallel (key_transpose k 9)+      Minor_Mode -> key_parallel (key_transpose k 3)++-- | Mediant minor of major key.+--+-- > key_mediant (T.C,T.Natural,Major_Mode) == Just (T.E,T.Natural,Minor_Mode)+key_mediant :: Key -> Maybe Key+key_mediant k =+    case key_mode k of+      Major_Mode -> Just (key_parallel (key_transpose k 4))+      _ -> Nothing++-- > fmap key_pc_set (key_lc_uc_parse "E")+key_pc_set :: Integral i => Key -> [i]+key_pc_set (n,a,md) =+    let pc0 = T.note_to_pc n + T.alteration_to_diff_err a+    in sort (map ((`mod` 12) . (+ pc0)) (mode_pc_seq md))++-- | Pretty-printer where 'Minor_Mode' is written in lower case (lc) and+-- alteration symbol is shown using indicated function.+key_lc_pp :: (T.Alteration_T -> String) -> Key -> String+key_lc_pp a_pp (n,a,m) =+    let c = T.note_pp n+        c' = if m == Minor_Mode then toLower c else c+    in c' : a_pp a++-- | 'key_lc_pp' with unicode (uc) alteration.+--+-- > map key_lc_uc_pp [(C,Sharp,Minor_Mode),(E,Flat,Major_Mode)] == ["c♯","E♭"]+key_lc_uc_pp :: Key -> String+key_lc_uc_pp = key_lc_pp (return . T.alteration_symbol)++-- | 'key_lc_pp' with ISO alteration.+key_lc_iso_pp :: Key -> String+key_lc_iso_pp = key_lc_pp T.alteration_iso++-- | 'key_lc_pp' with tonh alteration.+--+-- > map key_lc_tonh_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)]+key_lc_tonh_pp :: Key -> String+key_lc_tonh_pp = key_lc_pp T.alteration_tonh++-- > map key_identifier_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)]+key_identifier_pp :: (Show a, Show a1) => (a, a1, Mode_T) -> [Char]+key_identifier_pp (n,a,m) = map toLower (intercalate "_" [show n,show a,mode_pp m])++-- > import Data.Maybe+-- > mapMaybe note_char_to_key "CdEfGaB"+note_char_to_key :: Char -> Maybe Key+note_char_to_key c =+    let m = if isUpper c then Major_Mode else Minor_Mode+    in fmap (\n -> (n,T.Natural,m)) (T.parse_note_t True c)++-- | Parse 'Key' from /lc-uc/ string.+--+-- > import Data.Maybe+--+-- > let k = mapMaybe key_lc_uc_parse ["c","E","f♯","ab","G#"]+-- > in map key_lc_uc_pp k == ["c♮","E♮","f♯","a♭","G♯"]+key_lc_uc_parse :: String -> Maybe Key+key_lc_uc_parse k =+    let with_k a (n,_,m) = (n,a,m)+        with_a n a = fmap (with_k a) (note_char_to_key n)+    in case k of+         [c] -> note_char_to_key c+         [n,a] -> join (fmap (with_a n) (T.symbol_to_alteration_iso a))+         _ -> Nothing+ -- | Distance along circle of fifths path of indicated 'Key'.  A -- positive number indicates the number of sharps, a negative number -- the number of flats. ----- > key_fifths (A,Natural,Minor_Mode) == 0--- > key_fifths (A,Natural,Major_Mode) == 3--- > key_fifths (C,Natural,Minor_Mode) == -3-key_fifths :: Key -> Int+-- > key_fifths (T.A,T.Natural,Minor_Mode) == Just 0+-- > key_fifths (T.A,T.Natural,Major_Mode) == Just 3+-- > key_fifths (T.C,T.Natural,Minor_Mode) == Just (-3)+-- > key_fifths (T.B,T.Sharp,Minor_Mode) == Just 9+-- > key_fifths (T.E,T.Sharp,Major_Mode) == Just 11+-- > key_fifths (T.B,T.Sharp,Major_Mode) == Nothing+--+-- > zip (map key_lc_iso_pp key_sequence_42) (map key_fifths key_sequence_42)+key_fifths :: Key -> Maybe Int key_fifths (n,a,m) =-    let cf x = let (p,q) = circle_of_fifths x in p ++ q-        eq (Pitch n' a' _) = n == n' && a == a'-        (Just ix) = case m of-                      Major_Mode -> findIndex eq (cf c4)-                      Minor_Mode -> findIndex eq (cf a4)-    in if ix < 13 then negate ix else ix - 12+    let cf x = let (p,q) = T.circle_of_fifths x in p ++ q+        eq (T.Pitch n' a' _) = n == n' && a == a'+        ix = case m of+               Major_Mode -> findIndex eq (cf T.c4)+               Minor_Mode -> findIndex eq (cf T.a4)+    in fmap (\i -> if i < 13 then negate i else i - 12) ix++-- | Table mapping 'Key' to 'key_fifths' value.+key_fifths_tbl :: [(Key,Int)]+key_fifths_tbl =+    let f (k,n) = maybe Nothing (\n' -> Just (k,n')) n+    in mapMaybe f (zip key_sequence_42 (map key_fifths key_sequence_42))++-- | Lookup 'key_fifths' value in 'key_fifths_tbl'.+--+-- > let a = [0,1,-1,2,-2,3,-3,4,-4,5,-5]+-- > let f md = map key_lc_iso_pp . mapMaybe (fifths_to_key md)+-- > f Minor_Mode a+-- > f Major_Mode a+fifths_to_key :: Mode_T -> Int -> Maybe Key+fifths_to_key md n =+    let eq_f = (\((_,_,md'),n') -> md == md' && n == n')+    in fmap fst (find eq_f key_fifths_tbl)++-- | Given sorted pitch-class set, find simplest implied key in given mode.+--+-- > mapMaybe (implied_key Major_Mode) [[0,2,4],[1,3],[4,10],[3,9],[8,9]]+-- > map (implied_key Major_Mode) [[0,1,2],[0,1,3,4]] == [Nothing,Nothing]+implied_key :: Integral i => Mode_T -> [i] -> Maybe Key+implied_key md pc_set =+    let a_seq = [0,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6]+        key_seq = mapMaybe (fifths_to_key md) a_seq+    in find (\k -> pc_set `T.is_subset` key_pc_set k) key_seq++-- | 'key_fifths' of 'implied_key'.+implied_fifths :: Integral i => Mode_T -> [i] -> Maybe Int+implied_fifths md = join . fmap key_fifths . implied_key md++implied_key_err :: Integral i => Mode_T -> [i] -> Key+implied_key_err md = fromMaybe (error "implied_key") . implied_key md++implied_fifths_err :: Integral i => Mode_T -> [i] -> Int+implied_fifths_err md = fromMaybe (error "implied_fifths") . key_fifths . implied_key_err md

@@ -1,24 +1,95 @@ -- | List functions. module Music.Theory.List where +import Data.Either {- base -} import Data.Function {- base -}+import qualified Data.IntMap as Map {- containers -} import Data.List {- base -}-import qualified Data.List.Ordered as O {- data-ordlist -}-import Data.List.Split {- split -} import Data.Maybe {- base -}+import Data.Tree {- containers -}+import qualified Data.Traversable as T {- base -} +import qualified Data.List.Ordered as O {- data-ordlist -}+import qualified Data.List.Split as S {- split -}+import qualified Data.List.Split.Internals as S {- split -}++import qualified Control.Monad.Logic as L {- logict -}++-- | Data.Vector.slice, ie. starting index (zero-indexed) and number of elements.+--+-- > slice 4 5 [1..] == [5,6,7,8,9]+slice :: Int -> Int -> [a] -> [a]+slice i n = take n . drop i++-- | Variant of slice with start and end indices (zero-indexed).+--+-- > section 4 8 [1..] == [5,6,7,8,9]+section :: Int -> Int -> [a] -> [a]+section l r = take (r - l + 1) . drop l+ -- | Bracket sequence with left and right values. -- -- > bracket ('<','>') "1,2,3" == "<1,2,3>" bracket :: (a,a) -> [a] -> [a] bracket (l,r) x = l : x ++ [r] +unbracket' :: [a] -> (Maybe a,[a],Maybe a)+unbracket' x =+    case x of+      [] -> (Nothing,[],Nothing)+      l:x' -> let (m,r) = separate_last' x' in (Just l,m,r)++-- | The first & middle & last elements of a list.+--+-- > unbracket "[12]" == Just ('[',"12",']')+unbracket :: [t] -> Maybe (t,[t],t)+unbracket x =+    case unbracket' x of+      (Just l,m,Just r) -> Just (l,m,r)+      _ -> Nothing++unbracket_err :: [t] -> (t,[t],t)+unbracket_err = fromMaybe (error "unbracket") . unbracket+ -- | Variant where brackets are sequences. -- -- > bracket_l ("<:",":>") "1,2,3" == "<:1,2,3:>" bracket_l :: ([a],[a]) -> [a] -> [a] bracket_l (l,r) s = l ++ s ++ r +-- * Split++-- | Relative of 'splitOn', but only makes first separation.+--+-- > 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 []++-- | 'Splitter' comparing single element.+on_elem :: Eq a => a -> S.Splitter a+on_elem e = S.defaultSplitter { S.delimiter = S.Delimiter [(==) e] }++-- | Split before the indicated element.+--+-- > 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 :: Eq a => a -> [a] -> [[a]]+split_before = S.split . S.keepDelimsL . on_elem++-- * Rotate+ -- | Generic form of 'rotate_left'. genericRotate_left :: Integral i => i -> [a] -> [a] genericRotate_left n =@@ -63,6 +134,42 @@ 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' 3 2 "adjacent" == ["adj","jac","cen"]+adj' :: Int -> Int -> [a] -> [[a]]+adj' n k l =+    let r = take n l+    in if length r == n then r : adj' n k (drop k l) else []+ -- | Generic form of 'adj2'. genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)] genericAdj2 n l =@@ -73,6 +180,7 @@ -- | 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)]@@ -98,11 +206,55 @@ -- > interleave [1..3] [4..6] == [1,4,2,5,3,6] -- > interleave ".+-" "abc" == ".a+b-c" -- > interleave [1..3] [] == []-interleave :: [b] -> [b] -> [b]+interleave :: [a] -> [a] -> [a] interleave p q =     let u (i,j) = [i,j]     in concatMap u (zip p q) +-- | Interleave list of lists.  Allows lists to be of non-equal lenghts.+--+-- > interleave_set ["abcd","efgh","ijkl"] == "aeibfjcgkdhl"+-- > interleave_set ["abc","defg","hijkl"] == "adhbeicfjgkl"+interleave_set :: [[a]] -> [a]+interleave_set = concat . transpose++{-+import Safe {- safe -}++interleave_set l =+    case mapMaybe headMay l of+      [] -> []+      r -> r ++ interleave_set (mapMaybe tailMay l)+-}++-- | De-interleave /n/ lists.+--+-- > deinterleave 2 ".a+b-c" == [".+-","abc"]+-- > deinterleave 3 "aeibfjcgkdhl" == ["abcd","efgh","ijkl"]+deinterleave :: Int -> [a] -> [[a]]+deinterleave n = transpose . S.chunksOf n++-- | Special case for two-part deinterleaving.+--+-- > deinterleave2 ".a+b-c" == (".+-","abc")+deinterleave2 :: [t] -> ([t], [t])+deinterleave2 =+    let f l =+            case l of+              p:q:l' -> (p,q) : f l'+              _ -> []+    in unzip . f++{-+deinterleave2 =+    let f p q l =+            case l of+              [] -> (reverse p,reverse q)+              [a] -> (reverse (a:p),reverse q)+              a:b:l' -> rec (a:p) (b:q) l'+    in f [] []+-}+ -- | Variant that continues with the longer input. -- -- > interleave_continue ".+-" "abc" == ".a+b-c"@@ -121,15 +273,31 @@ interleave_rotations :: Int -> Int -> [b] -> [b] interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s) +generic_histogram :: (Ord a,Integral i) => [a] -> [(a,i)]+generic_histogram x =+    let g = group (sort x)+    in zip (map head g) (map genericLength g)++histogram_by :: Ord a => (a -> a -> Bool) -> [a] -> [(a,Int)]+histogram_by f x =+    let g = groupBy f (sort x)+    in zip (map head g) (map length g)+ -- | Count occurences of elements in list. ----- > histogram "hohoh" == [('h',3),('o',2)]-histogram :: (Ord a,Integral i) => [a] -> [(a,i)]-histogram x =-    let g = group (sort x)-        n = map genericLength g-    in zip (map head g) n+-- > map histogram ["","hohoh"] == [[],[('h',3),('o',2)]]+histogram :: Ord a => [a] -> [(a,Int)]+histogram = histogram_by (==) +duplicates_by :: Ord a => (a -> a -> Bool) -> [a] -> [a]+duplicates_by f = map fst . filter (\(_,n) -> n > 1) . histogram_by f++-- | Elements that appear more than once in the input.+--+-- > 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]]@@ -164,27 +332,79 @@ -- > cycles 3 [1..9] == [[1,4,7],[2,5,8],[3,6,9]] -- > cycles 4 [1..8] == [[1,5],[2,6],[3,7],[4,8]] cycles :: Int -> [a] -> [[a]]-cycles n = transpose . chunksOf n+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++-- | Replace all /p/ with /q/ in /s/.+--+-- > replace "_x_" "-X-" "an _x_ string" == "an -X- string"+-- > replace "ab" "cd" "ab ab cd ab" == "cd cd cd cd"+replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace p q s =+    let n = length p+    in case s of+         [] -> []+         c:s' -> if p `isPrefixOf` s+                 then q ++ replace p q (drop n s)+                 else c : replace p q s'++-- | Replace the /i/th value at /ns/ with /x/.+--+-- > replace_at "test" 2 'n' == "tent"+replace_at :: Integral i => [a] -> i -> a -> [a]+replace_at ns i x =+    let f j y = if i == j then x else y+    in zipWith f [0..] ns+ -- * Association lists --- | Given accesors for /key/ and /value/ collate input.+-- | Equivalent to 'groupBy' '==' 'on' /f/. ----- > let r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")]--- > in collate_on fst snd (zip "ABCBCD" "abcdef")-collate_on :: (Eq k,Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]-collate_on f g =+-- > let r = [[(1,'a'),(1,'b')],[(2,'c')],[(3,'d'),(3,'e')],[(4,'f')]]+-- > in group_on fst (zip [1,1,2,3,3,4] "abcdef") == r+group_on :: Eq x => (a -> x) -> [a] -> [[a]]+group_on f = map (map snd) . groupBy ((==) `on` fst) . map (\x -> (f x,x))++-- | Given accesors for /key/ and /value/ collate adjacent values.+collate_on_adjacent :: (Eq k,Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]+collate_on_adjacent f g =     let h l = case l of-                [] -> error "collate_on"+                [] -> error "collate_on_adjacent"                 l0:_ -> (f l0,map g l)-    in map h . groupBy ((==) `on` f) . sortBy (compare `on` f)+    in map h . group_on f +-- | 'collate_on_adjacent' of 'fst' and 'snd'.+--+-- > collate_adjacent (zip "TDD" "xyz") == [('T',"x"),('D',"yz")]+collate_adjacent :: Ord a => [(a,b)] -> [(a,[b])]+collate_adjacent = collate_on_adjacent fst snd++-- | 'sortOn' prior to 'collate_on_adjacent'.+--+-- > let r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")]+-- > in collate_on fst snd (zip "ABCBCD" "abcdef") == r+collate_on :: Ord k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]+collate_on f g = collate_on_adjacent f g . sortOn f+ -- | 'collate_on' of 'fst' and 'snd'. --+-- > collate (zip "TDD" "xyz") == [('D',"yz"),('T',"x")] -- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")] collate :: Ord a => [(a,b)] -> [(a,[b])] collate = collate_on fst snd +-- | Reverse of 'collate', inverse if order is not considered.+--+-- > uncollate [(1,"ac"),(2,"b")] == zip [1,1,2] "acb"+uncollate :: [(k,[v])] -> [(k,v)]+uncollate = concatMap (\(k,v) -> zip (repeat k) v)+ -- | Make /assoc/ list with given /key/. -- -- > with_key 'a' [1..3] == [('a',1),('a',2),('a',3)]@@ -208,12 +428,18 @@       e:r -> (e,reverse r)       _ -> error "dx_d'" --- | Integrate, ie. pitch class segment to interval sequence.+-- | Apply flip of /f/ between elements of /l/. --+-- > d_dx_by (,) "abcd" == [('b','a'),('c','b'),('d','c')]+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 l = if null l then [] else zipWith (-) (tail l) l+d_dx = d_dx_by (-)  -- | Elements of /p/ not in /q/. --@@ -250,18 +476,80 @@       [i] -> i       _ -> error "elem_index_unique" --- | Basis of 'find_bounds'.  There is an option to consider the last--- element specially, and if equal to the last span is given.-find_bounds' :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t)-find_bounds' scl f l x =+-- | Lookup that errors and prints message.+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++-- | Reverse lookup.+--+-- > reverse_lookup 'c' [] == Nothing+-- > reverse_lookup 'c' (zip [0..4] ['a'..]) == Just 2+reverse_lookup :: Eq b => b -> [(a,b)] -> Maybe a+reverse_lookup k = fmap fst . find ((== k) . snd)++{-+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'+-}+++-- | Basis of 'find_bounds_scl', indicates if /x/ is to the left or+-- right of the list, and it to the right whether equal or not.+-- 'Right' values will be correct if the list is not ascending,+-- however 'Left' values only make sense for ascending ranges.+--+-- > map (find_bounds' compare [(0,1),(1,2)]) [-1,0,1,2,3]+find_bounds' :: (t -> s -> Ordering) -> [(t,t)] -> s -> Either ((t,t),Ordering) (t,t)+find_bounds' f l x =     let g (p,q) = f p x /= GT && f q x == GT-        h (p,q) = f p x /= GT && f q x /= LT-        h' = if scl then h else g     in case l of-         [] -> Nothing-         [e] -> if h' e then Just e else Nothing-         e:l' -> if g e then Just e else find_bounds' scl f l' x+         [] -> error "find_bounds': nil"+         [(p,q)] -> if g (p,q) then Right (p,q) else Left ((p,q),f q x)+         (p,q):l' -> if f p x == GT+                     then Left ((p,q),GT)+                     else if g (p,q) then Right (p,q) else find_bounds' f l' x +decide_nearest' :: Ord o => (p -> o) -> (p,p) -> p+decide_nearest' f (p,q) = if f p < f q then p else q++-- | Decide if value is nearer the left or right value of a range.+decide_nearest :: (Num o,Ord o) => o -> (o, o) -> o+decide_nearest x = decide_nearest' (abs . (x -))++-- | Find the number that is nearest the requested value in an+-- ascending list of numbers.+--+-- > map (find_nearest_err [0,3.5,4,7]) [-1,1,3,5,7,9] == [0,0,3.5,4,7,7]+find_nearest_err :: (Num n,Ord n) => [n] -> n -> n+find_nearest_err l x =+    case find_bounds' compare (adj2 1 l) x of+      Left ((p,_),GT) -> p+      Left ((_,q),_) -> q+      Right (p,q) -> decide_nearest x (p,q)++find_nearest :: (Num n,Ord n) => [n] -> n -> Maybe n+find_nearest l x = if null l then Nothing else Just (find_nearest_err l x)++-- | Basis of 'find_bounds'.  There is an option to consider the last+-- element specially, and if equal to the last span is given.+find_bounds_scl :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t)+find_bounds_scl scl f l x =+    case find_bounds' f l x of+         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. --@@ -269,8 +557,18 @@ -- >     ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]} -- > in map f [0,1,3.5,5] == r find_bounds :: Bool -> (t -> s -> Ordering) -> [t] -> s -> Maybe (t,t)-find_bounds scl f l = find_bounds' scl f (adj2 1 l)+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]@@ -283,6 +581,18 @@ dropWhileRight :: (a -> Bool) -> [a] -> [a] dropWhileRight p = reverse . dropWhile p . reverse +-- | 'take' from right.+--+-- > take_right 3 "taking" == "ing"+take_right :: Int -> [a] -> [a]+take_right n = reverse . take n . reverse++-- | 'takeWhile' from right.+--+-- > take_while_right Data.Char.isDigit "A440" == "440"+take_while_right :: (a -> Bool) -> [a] -> [a]+take_while_right p = reverse . takeWhile p . reverse+ -- | Apply /f/ at first element, and /g/ at all other elements. -- -- > at_head negate id [1..5] == [-1,2,3,4,5]@@ -302,13 +612,20 @@       [i] -> [g i]       i:x' -> f i : at_last f g x' --- | Separate list into an initial list and a last element tuple.+-- | 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 x =-    let e:x' = reverse x-    in (reverse x',e)+separate_last = fmap (fromMaybe (error "separate_last")) . separate_last'  -- | Replace directly repeated elements with 'Nothing'. --@@ -320,6 +637,22 @@                 e:l' -> Just e : map (const Nothing) l'     in concatMap f . group +-- | 'zipWith' of list and it's own tail.+--+-- > zip_with_adj (,) "abcde" == [('a','b'),('b','c'),('c','d'),('d','e')]+zip_with_adj :: (a -> a -> b) -> [a] -> [b]+zip_with_adj f xs = zipWith f xs (tail xs)++-- | Type-specialised 'zip_with_adj'.+compare_adjacent_by :: (a -> a -> Ordering) -> [a] -> [Ordering]+compare_adjacent_by = zip_with_adj++-- | 'compare_adjacent_by' of 'compare'.+--+-- > compare_adjacent [0,1,3,2] == [LT,LT,GT]+compare_adjacent :: Ord a => [a] -> [Ordering]+compare_adjacent = compare_adjacent_by compare+ -- | 'Data.List.groupBy' does not make adjacent comparisons, it -- compares each new element to the start of the group.  This function -- is the adjacent variant.@@ -337,23 +670,42 @@                    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 = groupBy ((==) `on` isJust)+group_just = group_on isJust  -- | Predicate to determine if all elements of the list are '=='.+--+-- > all_equal "aaa" == True+all_equal :: Eq a => [a] -> Bool+all_equal l =+    case l of+      [] -> True+      [_] -> True+      x:xs -> all id (map (== x) xs)++-- | Variant using 'nub'. all_eq :: Eq n => [n] -> Bool all_eq = (== 1) . length . nub --- | 'groupBy' of 'sortBy'.+-- | '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 = groupBy ((==) `on` f) . sortBy (compare `on` f)+sort_group_on f = group_on f . sortOn f  -- | Maybe cons element onto list. --@@ -374,20 +726,24 @@       EQ -> g p q       r -> r --- | Invert 'Ordering'.-ordering_invert :: Ordering -> Ordering-ordering_invert o =-    case o of-      LT -> GT-      EQ -> EQ-      GT -> LT+-- | 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  -- | Sort sequence /a/ based on ordering of sequence /b/. -- -- > sort_to "abc" [1,3,2] == "acb" -- > sort_to "adbce" [1,4,2,3,5] == "abcde" sort_to :: Ord i => [e] -> [i] -> [e]-sort_to e = map fst . sortBy (compare `on` snd) . zip e+sort_to e = map fst . sortOn snd . zip e  -- | 'flip' of 'sort_to'. --@@ -399,12 +755,20 @@ sort_by_two_stage :: (Ord b,Ord c) => (a -> b) -> (a -> c) -> [a] -> [a] sort_by_two_stage f g = sortBy (two_stage_compare (compare `on` f) (compare `on` g)) +-- | 'sortBy' of 'n_stage_compare'.+sort_by_n_stage :: Ord b => [a -> b] -> [a] -> [a]+sort_by_n_stage f = sortBy (n_stage_compare (map (compare `on`) f))+ -- | Given a comparison function, merge two ascending lists. -- -- > mergeBy compare [1,3,5] [2,4] == [1..5] merge_by :: Compare_F a -> [a] -> [a] -> [a] merge_by = O.mergeBy +-- | 'merge_by' 'compare' 'on'.+merge_on :: Ord x => (a -> x) -> [a] -> [a] -> [a]+merge_on f = merge_by (compare `on` f)+ -- | 'O.mergeBy' of 'two_stage_compare'. merge_by_two_stage :: Ord b => (a -> b) -> Compare_F c -> (a -> c) -> [a] -> [a] -> [a] merge_by_two_stage f cmp g = O.mergeBy (two_stage_compare (compare `on` f) (cmp `on` g))@@ -449,8 +813,291 @@                                GT -> r : recur p q'     in recur +-- | First non-ascending pair of elements.+find_non_ascending :: (a -> a -> Ordering) -> [a] -> Maybe (a,a)+find_non_ascending cmp xs =+    case xs of+      p:q:xs' -> if cmp p q == GT then Just (p,q) else find_non_ascending cmp (q:xs')+      _ -> Nothing++-- | 'isNothing' of 'find_non_ascending'.+is_ascending_by :: (a -> a -> Ordering) -> [a] -> Bool+is_ascending_by cmp = isNothing . find_non_ascending cmp++-- | 'is_ascending_by' 'compare'.+is_ascending :: Ord a => [a] -> Bool+is_ascending = is_ascending_by compare++-- | 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++-- | Keep right variant of 'zipWith', where unused rhs values are returned.+--+-- > zip_with_kr (,) [1..3] ['a'..'e'] == ([(1,'a'),(2,'b'),(3,'c')],"de")+zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])+zip_with_kr f =+    let go r p q =+            case (p,q) of+              (i:p',j:q') -> go (f i j : r) p' q'+              _ -> (reverse r,q)+    in go []++-- | A 'zipWith' variant that always consumes an element from the left+-- hand side (lhs), but only consumes an element from the right hand+-- side (rhs) if the zip function is 'Right' and not if 'Left'.+-- There's also a secondary function to continue if the rhs ends+-- before the lhs.+zip_with_perhaps_rhs :: (a -> b -> Either c c) -> (a -> c) -> [a] -> [b] -> [c]+zip_with_perhaps_rhs f g lhs rhs =+    case (lhs,rhs) of+      ([],_) -> []+      (_,[]) -> map g lhs+      (p:lhs',q:rhs') -> case f p q of+                           Left r -> r : zip_with_perhaps_rhs f g lhs' rhs+                           Right r -> r : zip_with_perhaps_rhs f g lhs' rhs'++-- | Fill gaps in a sorted association list, range is inclusive at both ends.+--+-- > let r = [(1,'a'),(2,'x'),(3,'x'),(4,'x'),(5,'b'),(6,'x'),(7,'c'),(8,'x'),(9,'x')]+-- > in fill_gaps_ascending' 'x' (1,9) (zip [1,5,7] "abc") == r+fill_gaps_ascending :: (Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]+fill_gaps_ascending def_e (l,r) =+    let f i (j,e) = if j > i then Left (i,def_e) else Right (j,e)+        g i = (i,def_e)+    in zip_with_perhaps_rhs f g [l .. r]++-- | Direct definition.+fill_gaps_ascending' :: (Num n,Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]+fill_gaps_ascending' def (l,r) =+    let recur n x =+            if n > r+            then []+            else case x of+                   [] -> zip [n .. r] (repeat def)+                   (m,e):x' -> if n < m+                               then (n,def) : recur (n + 1) x+                               else (m,e) : recur (n + 1) x'+    in recur l++-- | 'minimum' and 'maximum' in one pass.+--+-- > minmax "minimumandmaximum" == ('a','x')+minmax :: Ord t => [t] -> (t,t)+minmax inp =+    case inp of+      [] -> error "minmax: null"+      x:xs -> let mm p (l,r) = (min p l,max p r) in foldr mm (x,x) xs+ -- * Bimap  -- | Apply /f/ to both elements of a two-tuple, ie. 'bimap' /f/ /f/. bimap1 :: (t -> u) -> (t,t) -> (u,u) bimap1 f (p,q) = (f p,f q)++-- | Append /k/ to the right of /l/ until result has /n/ places.+--+-- > 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 :: a -> Int -> [a] -> [a]+pad_right k n l = take n (l ++ repeat k)++-- | Append /k/ to the left of /l/ until result has /n/ places.+--+-- > map (pad_left '0' 2 . return) ['0' .. '9']+pad_left :: a -> Int -> [a] -> [a]+pad_left k n l = replicate (n - length l) k ++ l++-- * Embedding++-- | Locate first (leftmost) embedding of /q/ in /p/.+-- Return partial indices for failure at 'Left'.+--+-- > embedding ("embedding","ming") == Right [1,6,7,8]+-- > embedding ("embedding","mind") == Left [1,6,7]+embedding :: Eq t => ([t],[t]) -> Either [Int] [Int]+embedding =+    let recur n r (p,q) =+            case (p,q) of+              (_,[]) -> Right (reverse r)+              ([],_) -> Left (reverse r)+              (x:p',y:q') ->+                  let n' = n + 1+                      r' = if x == y then n : r else r+                  in recur n' r' (p',if x == y then q' else q)+    in recur 0 []++embedding_err :: Eq t => ([t],[t]) -> [Int]+embedding_err = either (error "embedding_err") id . embedding++-- | Does /q/ occur in sequence, though not necessarily adjacently, in /p/.+--+-- > is_embedding [1 .. 9] [1,3,7] == True+-- > is_embedding "embedding" "ming" == True+-- > is_embedding "embedding" "mind" == False+is_embedding :: Eq t => [t] -> [t] -> Bool+is_embedding p q = isRight (embedding (p,q))++all_embeddings_m :: (Eq t,L.MonadLogic m) => [t] -> [t] -> m [Int]+all_embeddings_m p q =+    let q_n = length q+        recur p' q' n k = -- n = length k+            if n == q_n+            then return (reverse k)+            else do (m,c) <- L.msum (map return p')+                    let k0:_ = k+                        c':_ = q'+                    L.guard (c == c' && (null k || m > k0))+                    let _:p'' = p'+                        _:q'' = q'+                    recur p'' q'' (n + 1) (m : k)+    in recur (zip [0..] p) q 0 []++-- | Enumerate indices for all embeddings of /q/ in /p/.+--+-- > all_embeddings "all_embeddings" "leg" == [[1,4,12],[1,7,12],[2,4,12],[2,7,12]]+all_embeddings :: Eq t => [t] -> [t] -> [[Int]]+all_embeddings p = L.observeAll . all_embeddings_m p++-- * Un-list++-- | Unpack one element list.+unlist1 :: [t] -> Maybe t+unlist1 l =+    case l of+      [e] -> Just e+      _ -> Nothing++-- | Erroring variant.+unlist1_err :: [t] -> t+unlist1_err = fromMaybe (error "unlist1") . unlist1++-- * Traversable++-- | Replace elements at 'Traversable' with result of joining with elements from list.+--+-- > let t = Node 0 [Node 1 [Node 2 [],Node 3 []],Node 4 []]+-- > putStrLn $ drawTree (fmap show t)+-- > let u = (adopt_shape (\_ x -> x) "abcde" t)+-- > putStrLn $ drawTree (fmap return u)+adopt_shape :: T.Traversable t => (a -> b -> c) -> [b] -> t a -> t c+adopt_shape jn l =+    let f (i:j) k = (j,jn k i)+        f [] _ = error "adopt_shape: rhs ends"+    in snd . T.mapAccumL f l++-- | Variant of 'adopt_shape' that considers only 'Just' elements at 'Traversable'.+--+-- > let {s = "a(b(cd)ef)ghi"+-- >     ;t = group_tree (begin_end_cmp_eq '(' ')') s}+-- > in adopt_shape_m (,) [1..13] t+adopt_shape_m :: T.Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> t (Maybe c)+adopt_shape_m jn l =+    let f (i:j) k = case k of+                      Nothing -> (i:j,Nothing)+                      Just k' -> (j,Just (jn k' i))+        f [] _ = error "adopt_shape_m: rhs ends"+    in snd . T.mapAccumL f l++-- * 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"+>     ;t = group_tree ((==) '{',(==) '}') l}+> in catMaybes (flatten t) == l++> let {d = putStrLn . drawTree . fmap show}+> in d (group_tree ((==) '(',(==) ')') "a(b(cd)ef)ghi")++-}+group_tree :: (a -> Bool,a -> Bool) -> [a] -> Tree (Maybe a)+group_tree (open_f,close_f) =+    let unit e = Node (Just e) []+        nil = Node Nothing []+        insert_e (Node t l) e = Node t (e:l)+        reverse_n (Node t l) = Node t (reverse l)+        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+              [] -> Node Nothing (reverse (fst st))+              e:x' -> if open_f e+                      then go (do_push (do_open st) e) x'+                      else if close_f e+                           then go (do_close (do_push st e)) x'+                           else go (do_push st e) x'+    in go ([],[])++-- * Indexing++-- | Remove element at index.+--+-- > remove_ix 5 "remove" == "remov"+-- > remove_ix 5 "short" == undefined+remove_ix :: Int -> [a] -> [a]+remove_ix k l = let (p,q) = splitAt k l in p ++ tail q++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_ixs [1,3] "select" == "ee"+select_ixs :: [Int] -> [a] -> [a]+select_ixs = operate_ixs True++-- > remove_ixs [1,3,5] "remove" == "rmv"+remove_ixs :: [Int] -> [a] -> [a]+remove_ixs = operate_ixs False++-- | Replace element at /i/ in /p/ by application of /f/.+--+-- > replace_ix negate 1 [1..3] == [1,-2,3]+replace_ix :: (a -> a) -> Int -> [a] -> [a]+replace_ix f i p =+    let (q,r:s) = splitAt i p+    in q ++ (f r : s)++-- | 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)+