AllChords.hs: try more common style and clean up things

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

src/AllChords.hs

@@ -1,73 +1,99 @@
--- 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 [] = [[]]
 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