{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-}
module Discovery where
import Control.Monad (forM_)
import Types
import Parser
import Transformations
import EuterpeaUtils
import MIDI (writeToMidi)
type WindowSize = Int
type Query a = (Check a, a)
data UserQuery a = ToPattern a => Check Pattern :@ a
upTo :: Time -> Time -> (Time, Time)
upTo = (,)
query :: Query Pattern -> MusicPiece -> [Pattern]
query (checker, base) =
filter (\p -> (base <=> p) checker) . slide (length base)
where
slide :: WindowSize -> [a] -> [[a]]
slide n xs = [ take n (drop m xs) | m <- [0..(length xs - n `max` 0)] ]
queryMatchCount :: Query Pattern -> MusicPiece -> Int
queryMatchCount q mp = length (query q mp)
query1 :: UserQuery (Time, Time)
query1 = (transpositionOf ~~ 0.5) :@ (21 `upTo` 28)
query2 :: UserQuery (Music Pitch)
query2 = (transpositionOf ~~ 0.5) :@ (line $ map ($qn) [c 4, e 4, g 4, c 5])
(??) :: ToPattern a => Song -> UserQuery a -> IO ()
infix 0 ??
song ?? q :@ base' = do
piece <- parseMusic song
putStrLn $ "Piece length: " ++ show (length piece)
let base = toPattern piece base'
putStrLn $ "Base length: " ++ show (length base)
let pats = filter (/= base) $ query (q, base) piece
putStrLn $ "Found patterns: " ++ show (length pats)
cd ("data/extracted/" ++ song ++ "/") $ do
emptyDirectory "."
writeToMidi "base.mid" base
forM_ (zip [1..] pats) $
\(i, p) -> writeToMidi ("occ" ++ show i ++ ".mid") p
class ToPattern a where
toPattern :: MusicPiece -> a -> Pattern
instance ToPattern (Time, Time) where
toPattern song (startT, endT) =
( takeWhile ((<= endT) . ontime)
. dropWhile ((< startT) . ontime)
) song
instance ToMusic1 a => ToPattern (Music a) where
toPattern _ = musicToPattern