diff --git a/README b/README index 5433f76..27f4d70 100644 --- a/README +++ b/README @@ -72,19 +72,19 @@ minor major seventh (5) diminished seventh (1) 0101: C#dim7 -half-diminished seventh (4) +half-diminished seventh (4) (just increment any of dim7) 0102: C#m7-5 0201: Em7-5 0111: Gm7-5 1101: Bbm7-5 -augmented seventh (4) +augmented seventh (4) (just raise 5th of dom7) 1001: Caug7 1203: Eaug7 0312: Gaug7 0110: Aaug7 -augmented major seventh (5) +augmented major seventh (5) (just raise 5th of M7) 1002: CaugM7 1303: EaugM7 0322: GaugM7 diff --git a/src/AllChords.hs b/src/AllChords.hs index 5a47a5d..251690a 100644 --- a/src/AllChords.hs +++ b/src/AllChords.hs @@ -1,44 +1,63 @@ --- playing around with: --- - generating all possible chords --- - generating (tertian) names for them --- - generating fingerings for them - --- cc is pitchclass count (usually 12) +-- This: +-- - generates all possible chords +-- - generates (tertian) names for them +-- - generates fingerings for them import Control.Arrow import Data.Function import Data.List import qualified Data.Map as M +-- | A "chord" is a series of intervals that add up to < octaveSize +-- (strictly less!). type Chord = [Int] -normalizeChord cc c = init . minimum $ zipWith (++) (tails c') (inits c') +allCycles :: [a] -> [[a]] +allCycles xs = zipWith (++) (tails xs) (inits xs) + +-- | Get a representative chord under the equivalence relation that +-- combines any two chords that differ only under changing-the-bass-note. +normalizeChord :: Int -> Chord -> Chord +normalizeChord octaveSize c = init . minimum $ allCycles cFillOctave where - c' = cc - sum c : c + cFillOctave = octaveSize - sum c : c -nChords :: Int -> Int -> [Chord] -nChords cc n = if n > cc then [] else nub . map (normalizeChord cc) $ concat - [map (i1:) (cOSNaiveOver cc (cc - i1) (n - 1) i1) | i1 <- [1..div cc n]] +allNormChords :: Int -> Int -> [Chord] +allNormChords octaveSize noteCount = if noteCount > octaveSize + then [] + else nub . map (normalizeChord octaveSize) $ concat + [ map (firstIntvl:) $ chordsNaive octaveSize + (octaveSize - firstIntvl) (noteCount - 1) firstIntvl + | firstIntvl <- [1 .. octaveSize `div` noteCount] + ] -cOSNaiveOver _ _ 1 _ = [[]] -cOSNaiveOver cc ccLeft n i = concat - [map (i1:) (cOSNaiveOver cc (ccLeft - i1) (n - 1) i) | i1 <- [i..ccLeft - i]] +chordsNaive :: Int -> Int -> Int -> Int -> [Chord] +chordsNaive _ _ 1 _ = [[]] +chordsNaive octaveSize octaveSizeLeft noteCount intvlBound = concat + [ map (intvl1:) (chordsNaive octaveSize (octaveSizeLeft - intvl1) + (noteCount - 1) intvlBound) + | intvl1 <- [intvlBound .. octaveSizeLeft - intvlBound] + ] diffs :: [Int] -> [Int] diffs (a1:a2:as) = (a2 - a1) : diffs (a2:as) diffs _ = [] makeChord :: Int -> [(String, Int)] -> (Chord, [String]) -makeChord n l = ( - normalizeChord 12 . map (`mod` 12) . diffs $ 0 : sort (map snd l), - map fst l) +makeChord octaveSize l = + ( normalizeChord octaveSize . map (`mod` octaveSize) . diffs $ + 0 : sort (map snd l) + , map fst l + ) -i3 = [("b3", 3), ("M3", 4), ("sus4", 5)] -i5 = [("b5", 6), ("M5", 7), ("#5", 8)] -i7 = [("bb7", 9), ("b7", 10), ("M7", 11)] -i9 = [("b9", 1), ("M9", 2)] ---i9 = [("b9", 1), ("M9", 2), ("#9", 3)] -i6 = [("#6", 10)] +-- | Uses M for Major tertian tonic notes, +/- for sharp/flat, and s for +-- off-tonic "suspensions". +i3, i5, i7, i9, i6 :: [(String, Int)] +i3 = [("-3", 3), ("M3", 4), ("s4", 5)] +i5 = [("-5", 6), ("M5", 7), ("+5", 8)] +i7 = [("-7", 10), ("M7", 11)] +i9 = [("-9", 1), ("M9", 2)] +i6 = [("s6", 9), ("+6", 10)] choose :: Int -> [a] -> [[a]] choose 0 [] = [[]] @@ -46,28 +65,35 @@ choose _ [] = [] choose n (a:l) = map (a:) (choose (n - 1) l) ++ choose n l interestingChords :: Int -> Int -> [(Chord, [String])] -interestingChords cc n = filter ((/= 0) . head . fst) . map (makeChord n) . - concatMap sequence $ choose (n - 1) [i3, i5, i6, i7, i9] +interestingChords octaveSize noteCount = filter ((/= 0) . head . fst) . + map (makeChord octaveSize) . concatMap sequence $ + choose (noteCount - 1) [i3, i5, i7, i9, i6] +ukeOffsets :: [Int] ukeOffsets = [7, 0, 4, 9] -offsetsToChord cc = normalizeChord cc . diffs . sort +offsetsToChord :: Int -> [Int] -> Chord +offsetsToChord octaveSize = normalizeChord octaveSize . diffs . sort +main :: IO () main = do - let - cc = 12 - n = 4 - chordNameMap = M.fromListWith (++) $ - [(c, []) | c <- nChords cc n] ++ - map (second (:[])) (interestingChords cc n) - remCr1 s l = if length l <= 1 then l else filter (not . s) l - removeCrapChords = remCr1 (elem "sus4") . remCr1 (elem "#6") - chordPlayMap = M.fromListWith (++) . filter ((/= 0) . head . fst) . - map (\ o -> (offsetsToChord cc $ zipWith (+) ukeOffsets o, [o])) . - sequence $ replicate (length ukeOffsets) [0..11] - showPlay = concatMap show - showChords = show . map concat . removeCrapChords - putStrLn . unlines . - map (\ (k, (v1, v2)) -> show k ++ " " ++ showPlay - (minimumBy (compare `on` maximum) v1) ++ " " ++ showChords v2) . - M.toList $ M.intersectionWith (,) chordPlayMap chordNameMap + let octaveSize = 12 + noteCount = 4 + chordNameMap = M.fromListWith (++) $ + [(c, []) | c <- allNormChords octaveSize noteCount] ++ + map (second (:[])) (interestingChords octaveSize noteCount) + remCr1 s l = if length l <= 1 then l else filter (not . s) l + removeCrapChords = remCr1 ("+5" `elem`) . + remCr1 ("s6" `elem`) . remCr1 ("+6" `elem`) + chordPlayMap = M.fromListWith (++) . filter ((/= 0) . head . fst) . + map (\ o -> ( offsetsToChord octaveSize $ zipWith (+) ukeOffsets o + , [o] + ) + ) . + sequence $ replicate (length ukeOffsets) [0 .. octaveSize - 1] + showPlay = concatMap show + showChords = show . map concat . removeCrapChords + putStrLn . unlines . + map (\ (k, (v1, v2)) -> show k ++ " " ++ showPlay + (minimumBy (compare `on` maximum) v1) ++ " " ++ showChords v2) . + M.toList $ M.intersectionWith (,) chordPlayMap chordNameMap