Skip to content

Instantly share code, notes, and snippets.

@bananu7
Forked from mikusp/a.hs
Created September 1, 2014 16:29
Show Gist options
  • Save bananu7/39bf8688c37ddcc37c23 to your computer and use it in GitHub Desktop.
Save bananu7/39bf8688c37ddcc37c23 to your computer and use it in GitHub Desktop.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment