a.hs

{-# LANGUAGE MagicHash, RecordWildCards #-}

import qualified Data.Map as Map
import Data.List
import Data.Maybe

main = print $ recognize chords [F#,B,D#,A,E]

{-- types --}
type Interval = Int

data Chord = Chord {
    root :: Note
  , name :: String
  , intervals :: [Interval]
}

instance Show Chord where
  show (Chord root name invs) = show root ++ name ++ if head invs /= 0 then
    "/" ++ show (toEnum $ mod (fromEnum root + head invs) 12 :: Note)
    else
    ""

data Note = A | A# | B | C | C# | D |
  D# | E | F | F# | G | G#
  deriving (Eq, Ord, Enum, Show)

data ChordResult = ChordResult {
    rootNotePlayed :: Bool
  , allNotesPlayed :: Bool
  , rootNoteIsBase :: Bool
  , chord :: Chord
  , accuracy :: Int
}

instance Show ChordResult where
  show ChordResult{..} = name chord ++ " " ++ show rootNotePlayed ++ " " ++
    show allNotesPlayed ++ " " ++ show rootNoteIsBase ++ " " ++ show accuracy ++ "\n"

{-- recognized types of chords --}
chords :: Map.Map [Interval] String
chords = Map.fromList $ [
    ([0,7], "5")
  , ([0,4,7], "")
  , ([0,3,7], "m")
  , ([0,2,7], "sus2")
  , ([0,5,7], "sus4")
  , ([0,3,7,9], "m6")
  , ([0,4,7,10], "7")
  , ([0,3,7,10], "m7")
  , ([0,4,7,11], "M7")
  , ([0,3,6], "dim")
  , ([0,5,7,10], "7sus4")
  , ([0,2,4,7], "add9")
  , ([0,2,4,7,10], "9")
  , ([0,2,3,7,10], "m9")
  , ([0,2,3,5,7,10], "m11")
  , ([0,4,5,7,10], "7add11")]

{-- main functions --}
recognize :: Map.Map [Interval] String -> [Note] -> Maybe Chord
recognize db n = listToMaybe $ map chord $ recognize' db n

recognize' :: Map.Map [Interval] String -> [Note] -> [ChordResult]
recognize' db notes = sort' $ sort'' $ sort''' $ sortLev list
  where
    sort' = sortBy (\x y -> comp rootNotePlayed x y)
    sort'' = sortBy (\x y -> comp allNotesPlayed x y)
    sort''' = sortBy (\x y -> comp rootNoteIsBase x y)
    -- reverse sort
    sortLev = sortBy (\x y -> comp accuracy y x)

    comp f x y = compare (f y) (f x)

    list = map conv $ filterMatchingChords db notes
    conv (root,invs,typeInvs,typ) = ChordResult {
          rootNotePlayed = 0 `elem` invs
        , allNotesPlayed = null (typeInvs \\ invs)
        , rootNoteIsBase = head invs == 0
        , chord = Chord root typ invs
        , accuracy = levenshtein (simple invs) (simple typeInvs)}

matchingTypes :: Map.Map [Interval] String -> [Interval] -> [([Interval], String)]
matchingTypes db ints = case Map.lookup (simple ints) db of
  Just val -> [(ints,val)]
  _ -> Map.toList $ Map.filterWithKey (\x _ -> levenshtein (simple ints) x <= 1) db

filterMatchingChords :: Map.Map [Interval] String -> [Note] -> [(Note,[Interval],[Interval],String)]
filterMatchingChords db n = zipWithOnPred toFourTuple chordSimilar ints namedInts
  where
    toFourTuple (a,b) (c,d,e) = (a,b,d,e)
    ints = notesToIntervals n
    namedInts = concat $ map (rep . (fmap $ matchingTypes db)) ints

rep (x,xs) = [(x,y,z) | (y,z) <- xs]

{-- utils --}
{-- same root notes and matching intervals --}
chordSimilar :: (Eq a, Eq b, Ord b) => (a, [b]) -> (a, [b], c) -> Bool
chordSimilar (a,b) (c,d,_) = (a == c) && (levenshtein (simple b) (simple d) <= 1) --(b `isPartOf` d)

simple :: (Ord a) => [a] -> [a]
simple = sort . nub

makeIntervals :: Note -> [Note] -> [Interval]
makeIntervals root note = map (\x -> semitones root x) note

notesToIntervals :: [Note] -> [(Note,[Interval])]
notesToIntervals notes = map foo [A .. G#]
  where
    foo x = (x , makeIntervals x notes)

semitones :: Note -> Note -> Interval
semitones x y | x <= y = dist
              | otherwise = dist + 12
  where
    dist = (fromEnum y) - (fromEnum x)

--isPartOf :: (Eq a) => [a] -> [a] -> Bool
--isPartOf a b = (length a) == (length $ intersect a b)

zipWithOnPred :: (a -> b -> c) -> (a -> b -> Bool) -> [a] -> [b] -> [c]
zipWithOnPred f pred a b = go a b []
  where
    go [] _ acc = acc
    go _ [] acc = acc
    go (a:as) bs acc = go as bs $ acc ++ acc'
      where
        acc' = map (f a) $ filter (pred a) bs

levenshtein :: (Eq a) => [a] -> [a] -> Int
levenshtein a b = case min i j of
  0 -> max i j
  _ -> minimum [levenshtein (init a) b + 1, levenshtein a (init b) + 1,
    levenshtein (init a) (init b) + cost]
  where
    i = length a
    j = length b
    cost | last a == last b = 0
         | otherwise = 1