Chords.hs

module Sound.Tidal.Chords where

{-
    Chords.hs - For .. chords
    Copyright (C) 2020, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Data.Maybe

import Sound.Tidal.Pattern

-- * Chord definitions

-- ** Major chords

major :: Num a => [a]
major = [0,4,7]
aug :: Num a => [a]
aug = [0,4,8]
six :: Num a => [a]
six = [0,4,7,9]
sixNine :: Num a => [a]
sixNine = [0,4,7,9,14]
major7 :: Num a => [a]
major7 = [0,4,7,11]
major9 :: Num a => [a]
major9 = [0,4,7,11,14]
add9 :: Num a => [a]
add9 = [0,4,7,14]
major11 :: Num a => [a]
major11 = [0,4,7,11,14,17]
add11 :: Num a => [a]
add11 = [0,4,7,17]
major13 :: Num a => [a]
major13 = [0,4,7,11,14,21]
add13 :: Num a => [a]
add13 = [0,4,7,21]

-- ** Dominant chords

dom7 :: Num a => [a]
dom7 = [0,4,7,10]
dom9 :: Num a => [a]
dom9 = [0,4,7,14]
dom11 :: Num a => [a]
dom11 = [0,4,7,17]
dom13 :: Num a => [a]
dom13 = [0,4,7,21]
sevenFlat5 :: Num a => [a]
sevenFlat5 = [0,4,6,10]
sevenSharp5 :: Num a => [a]
sevenSharp5 = [0,4,8,10]
sevenFlat9 :: Num a => [a]
sevenFlat9 = [0,4,7,10,13]
nine :: Num a => [a]
nine = [0,4,7,10,14]
eleven :: Num a => [a]
eleven = [0,4,7,10,14,17]
thirteen :: Num a => [a]
thirteen = [0,4,7,10,14,17,21]

-- ** Minor chords

minor :: Num a => [a]
minor = [0,3,7]
diminished :: Num a => [a]
diminished = [0,3,6]
minorSharp5 :: Num a => [a]
minorSharp5 = [0,3,8]
minor6 :: Num a => [a]
minor6 = [0,3,7,9]
minorSixNine :: Num a => [a]
minorSixNine = [0,3,9,7,14]
minor7flat5 :: Num a => [a]
minor7flat5 = [0,3,6,10]
minor7 :: Num a => [a]
minor7 = [0,3,7,10]
minor7sharp5 :: Num a => [a]
minor7sharp5 = [0,3,8,10]
minor7flat9 :: Num a => [a]
minor7flat9 = [0,3,7,10,13]
minor7sharp9 :: Num a => [a]
minor7sharp9 = [0,3,7,10,15]
diminished7 :: Num a => [a]
diminished7 = [0,3,6,9]
minor9 :: Num a => [a]
minor9 = [0,3,7,10,14]
minor11 :: Num a => [a]
minor11 = [0,3,7,10,14,17]
minor13 :: Num a => [a]
minor13 = [0,3,7,10,14,17,21]
minorMajor7 :: Num a => [a]
minorMajor7 = [0,3,7,11]

-- ** Other chords

one :: Num a => [a]
one = [0]
five :: Num a => [a]
five = [0,7]
sus2 :: Num a => [a]
sus2 = [0,2,7]
sus4 :: Num a => [a]
sus4 = [0,5,7]
sevenSus2 :: Num a => [a]
sevenSus2 = [0,2,7,10]
sevenSus4 :: Num a => [a]
sevenSus4 = [0,5,7,10]
nineSus4 :: Num a => [a]
nineSus4 = [0,5,7,10,14]

-- ** Questionable chords

sevenFlat10 :: Num a => [a]
sevenFlat10 = [0,4,7,10,15]
nineSharp5 :: Num a => [a]
nineSharp5 = [0,1,13]
minor9sharp5 :: Num a => [a]
minor9sharp5 = [0,1,14]
sevenSharp5flat9 :: Num a => [a]
sevenSharp5flat9 = [0,4,8,10,13]
minor7sharp5flat9 :: Num a => [a]
minor7sharp5flat9 = [0,3,8,10,13]
elevenSharp :: Num a => [a]
elevenSharp = [0,4,7,10,14,18]
minor11sharp :: Num a => [a]
minor11sharp = [0,3,7,10,14,18]

-- * Chord functions

-- | @chordate cs m n@ selects the @n@th "chord" (a chord is a list of Ints)
-- from a list of chords @cs@ and transposes it by @m@
-- chordate :: Num b => [[b]] -> b -> Int -> [b]
-- chordate cs m n = map (+m) $ cs!!n

-- | @enchord chords pn pc@ turns every note in the note pattern @pn@ into
-- a chord, selecting from the chord lists @chords@ using the index pattern
-- @pc@.  For example, @Chords.enchord [Chords.major Chords.minor] "c g" "0 1"@
-- will create a pattern of a C-major chord followed by a G-minor chord.
-- enchord :: Num a => [[a]] -> Pattern a -> Pattern Int -> Pattern a
-- enchord chords pn pc = flatpat $ (chordate chords) <$> pn <*> pc

{-|
  The @chordTable@ function outputs a list of all available chords and their
  corresponding notes. For example, its first entry is @("major",[0,4,7])@ which
  means that a major triad is formed by the root (0), the major third (4 semitones
  above the root), and the perfect fifth (7 semitones above the root).

  As the list is big, you can use the function 'chordL'.

  If you know the notes from a chord, but can’t find the name of it, you can use this Haskell code to do a reverse look up into the table:

  > filter (\(_,x)->x==[0,4,7,10]) chordTable

  This will output @[("dom7",[0,4,7,10])]@

  (You’ll need to run @import Sound.Tidal.Chords@ before using this function.)
-}
chordTable :: Num a => [(String, [a])]
chordTable = [("major", major),
              ("maj", major),
              ("M", major),
              ("aug", aug),
              ("plus", aug),
              ("sharp5", aug),
              ("six", six),
              ("6", six),
              ("sixNine", sixNine),
              ("six9", sixNine),
              ("sixby9", sixNine),
              ("6by9", sixNine),
              ("major7", major7),
              ("maj7", major7),
              ("major9", major9),
              ("maj9", major9),
              ("add9", add9),
              ("major11", major11),
              ("maj11", major11),
              ("add11", add11),
              ("major13", major13),
              ("maj13", major13),
              ("add13", add13),
              ("dom7", dom7),
              ("dom9", dom9),
              ("dom11", dom11),
              ("dom13", dom13),
              ("sevenFlat5", sevenFlat5),
              ("7f5", sevenFlat5),
              ("sevenSharp5", sevenSharp5),
              ("7s5", sevenSharp5),
              ("sevenFlat9", sevenFlat9),
              ("7f9", sevenFlat9),
              ("nine", nine),
              ("eleven", eleven),
              ("11", eleven),
              ("thirteen", thirteen),
              ("13", thirteen),
              ("minor", minor),
              ("min", minor),
              ("m", minor),
              ("diminished", diminished),
              ("dim", diminished),
              ("minorSharp5", minorSharp5),
              ("msharp5", minorSharp5),
              ("mS5", minorSharp5),
              ("minor6", minor6),
              ("min6", minor6),
              ("m6", minor6),
              ("minorSixNine", minorSixNine),
              ("minor69", minorSixNine),
              ("min69", minorSixNine),
              ("minSixNine", minorSixNine),
              ("m69", minorSixNine),
              ("mSixNine", minorSixNine),
              ("m6by9", minorSixNine),
              ("minor7flat5", minor7flat5),
              ("minor7f5", minor7flat5),
              ("min7flat5", minor7flat5),
              ("min7f5", minor7flat5),
              ("m7flat5", minor7flat5),
              ("m7f5", minor7flat5),
              ("minor7", minor7),
              ("min7", minor7),
              ("m7", minor7),
              ("minor7sharp5", minor7sharp5),
              ("minor7s5", minor7sharp5),
              ("min7sharp5", minor7sharp5),
              ("min7s5", minor7sharp5),
              ("m7sharp5", minor7sharp5),
              ("m7s5", minor7sharp5),
              ("minor7flat9", minor7flat9),
              ("minor7f9", minor7flat9),
              ("min7flat9", minor7flat9),
              ("min7f9", minor7flat9),
              ("m7flat9", minor7flat9),
              ("m7f9", minor7flat9),
              ("minor7sharp9", minor7sharp9),
              ("minor7s9", minor7sharp9),
              ("min7sharp9", minor7sharp9),
              ("min7s9", minor7sharp9),
              ("m7sharp9", minor7sharp9),
              ("m7s9", minor7sharp9),
              ("diminished7", diminished7),
              ("dim7", diminished7),
              ("minor9", minor9),
              ("min9", minor9),
              ("m9", minor9),
              ("minor11", minor11),
              ("min11", minor11),
              ("m11", minor11),
              ("minor13", minor13),
              ("min13", minor13),
              ("m13", minor13),
              ("minorMajor7", minorMajor7),
              ("minMaj7", minorMajor7),
              ("mmaj7", minorMajor7),
              ("one", one),
              ("1", one),
              ("five", five),
              ("5", five),
              ("sus2", sus2),
              ("sus4", sus4),
              ("sevenSus2", sevenSus2),
              ("7sus2", sevenSus2),
              ("sevenSus4", sevenSus4),
              ("7sus4", sevenSus4),
              ("nineSus4", nineSus4),
              ("ninesus4", nineSus4),
              ("9sus4", nineSus4),
              ("sevenFlat10", sevenFlat10),
              ("7f10", sevenFlat10),
              ("nineSharp5", nineSharp5),
              ("9sharp5", nineSharp5),
              ("9s5", nineSharp5),
              ("minor9sharp5", minor9sharp5),
              ("minor9s5", minor9sharp5),
              ("min9sharp5", minor9sharp5),
              ("min9s5", minor9sharp5),
              ("m9sharp5", minor9sharp5),
              ("m9s5", minor9sharp5),
              ("sevenSharp5flat9", sevenSharp5flat9),
              ("7s5f9", sevenSharp5flat9),
              ("minor7sharp5flat9", minor7sharp5flat9),
              ("m7sharp5flat9", minor7sharp5flat9),
              ("elevenSharp", elevenSharp),
              ("11s", elevenSharp),
              ("minor11sharp", minor11sharp),
              ("m11sharp", minor11sharp),
              ("m11s", minor11sharp)
             ]

-- | Look up a specific chord: @chordL "minor7"@ returns @(0>1)|[0,3,7,10]@.
chordL :: Num a => Pattern String -> Pattern [a]
chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p

{-|
Outputs all the available chords:

@
major maj M aug plus sharp5 six 6 sixNine six9 sixby9 6by9 major7 maj7
major9 maj9 add9 major11 maj11 add11 major13 maj13 add13 dom7 dom9 dom11
dom13 sevenFlat5 7f5 sevenSharp5 7s5 sevenFlat9 7f9 nine eleven 11 thirteen 13
minor min m diminished dim minorSharp5 msharp5 mS5 minor6 min6 m6 minorSixNine
minor69 min69 minSixNine m69 mSixNine m6by9 minor7flat5 minor7f5 min7flat5
min7f5 m7flat5 m7f5 minor7 min7 m7 minor7sharp5 minor7s5 min7sharp5 min7s5
m7sharp5 m7s5 minor7flat9 minor7f9 min7flat9 min7f9 m7flat9 m7f9 minor7sharp9
minor7s9 min7sharp9 min7s9 m7sharp9 m7s9 diminished7 dim7 minor9 min9 m9
minor11 min11 m11 minor13 min13 m13 minorMajor7 minMaj7 mmaj7 one 1 five 5
sus2 sus4 sevenSus2 7sus2 sevenSus4 7sus4 nineSus4 ninesus4 9sus4 sevenFlat10
7f10 nineSharp5 9sharp5 9s5 minor9sharp5 minor9s5 min9sharp5 min9s5 m9sharp5
m9s5 sevenSharp5flat9 7s5f9 minor7sharp5flat9 m7sharp5flat9 elevenSharp 11s
minor11sharp m11sharp m11s
@

(You’ll need to run @import Sound.Tidal.Chords@ before using this function.)
-}
chordList :: String
chordList = unwords $ map fst (chordTable :: [(String, [Int])])

data Modifier = Range Int | Drop Int | Invert | Open deriving Eq

instance Show Modifier where
  show (Range i) = "Range " ++ show i
  show (Drop i) = "Drop " ++ show i
  show Invert = "Invert"
  show Open = "Open"

applyModifier :: (Enum a, Num a) => Modifier -> [a] -> [a]
applyModifier (Range i) ds = take i $ concatMap (\x -> map (+ x) ds) [0,12..]
applyModifier Invert [] = []
applyModifier Invert (d:ds) = ds ++ [d+12]
applyModifier Open ds = case length ds > 2 of
                              True -> [ (ds !! 0 - 12), (ds !! 2 - 12), (ds !! 1) ] ++ reverse (take (length ds - 3) (reverse ds))
                              False -> ds
applyModifier (Drop i) ds = case length ds < i of
                              True -> ds
                              False -> (ds!!s - 12):(xs ++ drop 1 ys)
                          where (xs,ys) = splitAt s ds
                                s = length ds - i

applyModifierPat :: (Num a, Enum a) => Pattern [a] -> Pattern [Modifier] -> Pattern [a]
applyModifierPat pat modsP = do
                        ch <- pat
                        ms <- modsP
                        return $ foldl (flip applyModifier) ch ms

applyModifierPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern [a] -> [Pattern [Modifier]] -> Pattern [b]
applyModifierPatSeq f pat [] = fmap (map f) pat
applyModifierPatSeq f pat (mP:msP) = applyModifierPatSeq f (applyModifierPat pat mP) msP

chordToPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern b
chordToPatSeq f noteP nameP modsP = uncollect $ do
                    n  <- noteP
                    name <- nameP
                    let ch = map (+ n) (fromMaybe [0] $ lookup name chordTable)
                    applyModifierPatSeq f (return ch) modsP

-- | Turns a given pattern of some 'Num' type, a pattern of chord names, and a
-- list of patterns of modifiers into a chord pattern
chord :: (Num a, Enum a) =>  Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern a
chord = chordToPatSeq id