module Main where import qualified Options.Applicative as OP import qualified Graphics.PDF as PDF import qualified Sound.MIDI.Message.Class.Query as Query import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.File.Load as MidiLoad import qualified Sound.MIDI.File.Event as MidiEvent import qualified Sound.MIDI.File as MidiFile import qualified Data.EventList.Absolute.TimeBody as AbsEventList import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.Array as Array import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.Foldable as Fold import Data.IntMap (IntMap) import Data.Map (Map) import Data.Array (Array, listArray, (!)) import Data.Tuple.HT (mapTriple, thd3) import Data.String (fromString) import Data.Complex (Complex((:+))) import Control.Monad (join) import Control.Applicative ((<$>), (<*>)) {- | Terminated tubes sorted with respect to upper boundary and unterminated tubes sorted with respect to note. -} type VisibleTubes = (Map Double [(Double, Int)], IntMap Double) {- | This also handles three kinds of corruption: NoteOff without NoteOn, NoteOn without NoteOff, duplicate NoteOn (which is kind of special case of NoteOn without NoteOff) -} welcomeNextEvent :: (Double, (Int, Bool)) -> VisibleTubes -> VisibleTubes welcomeNextEvent (timeStamp, (pitch, noteOn)) (terminated, unterminated) = (case IntMap.lookup pitch unterminated of Nothing -> terminated Just timeStart -> Map.insertWith (++) timeStamp [(timeStart, pitch)] terminated , if noteOn then IntMap.insert pitch timeStamp unterminated else IntMap.delete pitch unterminated) farewellEvents :: Double -> VisibleTubes -> VisibleTubes farewellEvents time (terminated, unterminated) = (thd3 $ Map.splitLookup time terminated, unterminated) layoutTubes :: (Query.C ev) => Double -> VoiceMsg.Pitch -> AbsEventList.T Double ev -> [(Double, (Int, Bool))] layoutTubes timeStep zeroKey = AbsEventList.toPairList . AbsEventList.mapMaybe (\ev -> do (_c, (_v, p, noteOn)) <- Query.noteExplicitOff ev return (VoiceMsg.subtractPitch zeroKey p, noteOn)) . AbsEventList.mapTime (/timeStep) windowInitialize :: Double -> [(Double, (Int, Bool))] -> (VisibleTubes, [(Double, (Int, Bool))]) windowInitialize time events = case span ((<=time) . fst) events of (displayed, remaining) -> (foldl (flip welcomeNextEvent) (Map.empty, IntMap.empty) displayed, remaining) windowMove :: (Double, Double) -> (VisibleTubes, [(Double, (Int, Bool))]) -> (VisibleTubes, [(Double, (Int, Bool))]) windowMove (newFrom, newTo) (currentDisplay, events) = case span ((<=newTo) . fst) events of (newDisplayed, remaining) -> (foldl (flip welcomeNextEvent) (farewellEvents newFrom currentDisplay) newDisplayed, remaining) windowLayout :: VisibleTubes -> [(Double, Maybe Double, Int)] windowLayout (terminated, unterminated) = Fold.fold (Map.mapWithKey (\to -> map (\(from, pitch) -> (from, Just to, pitch))) terminated) ++ map (\(pitch, from) -> (from, Nothing, pitch)) (IntMap.toList unterminated) mergeTracksToAbsolute :: MidiFile.T -> AbsEventList.T Double MidiEvent.T mergeTracksToAbsolute (MidiFile.Cons typ division tracks) = AbsEventList.mapTime realToFrac $ EventList.toAbsoluteEventList 0 $ MidiFile.mergeTracks typ $ map (MidiFile.secondsFromTicks division) tracks noteNames :: [Char] noteNames = ['C', '#', 'D', '#', 'E', 'F', '#', 'G', '#', 'A', '#', 'H', 'C'] noteColors :: Array Int PDF.Color noteColors = let xs = (,,) 90 0 0 : (,,) 90 15 0 : (,,) 95 35 0 : (,,) 95 60 5 : (,,) 95 100 10 : (,,) 25 100 25 : (,,) 5 70 20 : (,,) 5 45 20 : (,,) 0 20 65 : (,,) 35 0 70 : (,,) 55 0 55 : (,,) 75 35 75 : (,,) 90 0 0 : [] in listArray (0, length xs - 1) $ map (\(r,g,b) -> PDF.Rgb (0.01*r) (0.01*g) (0.01*b)) xs grey :: Double -> PDF.Color grey brightness = PDF.Rgb brightness brightness brightness colorFromPitch :: Int -> PDF.Color colorFromPitch pitch = if Array.inRange (Array.bounds noteColors) pitch then noteColors ! pitch else grey 0.5 writePDF :: FilePath -> PDF.FontName -> Int -> [[(Double, Maybe Double, Int)]] -> IO () writePDF path fontName fontHeight_ blocks = do let fontHeight = fromIntegral fontHeight_ width = 16 * fontHeight height = 9 * fontHeight bottom = 0.5 * fontHeight left = 20 gradientHeight = 9 boxLeftFromPitch pitch = left + fromIntegral pitch * fontHeight rect = PDF.PDFRect 0 0 width height let (bowHeight, tube) = if True then (0.2, \l b r t -> do let b1 = b - bowHeight*fontHeight let t1 = t - bowHeight*fontHeight PDF.beginPath (l:+b) PDF.curveto (l:+b1) (r:+b1) (r:+b) PDF.lineto (r:+t) PDF.curveto (r:+t1) (l:+t1) (l:+t) ) else (0, \l b r t -> PDF.addShape $ PDF.Rectangle (l:+b) (r:+t)) stdFont <- either (fail . show) return =<< PDF.mkStdFont fontName PDF.runPdf path PDF.standardDocInfo rect $ Fold.for_ blocks $ \block -> do page <- PDF.addPage Nothing PDF.drawWithPage page $ do PDF.fillColor PDF.black PDF.fill $ PDF.Rectangle (0:+0) (width:+height) Fold.for_ block $ \(from,mTo,pitch) -> do let boxLeft = boxLeftFromPitch pitch let to = maybe height ((fontHeight*) . subtract 0.1) mTo PDF.paintWithShading (PDF.AxialShading boxLeft (bottom+fontHeight*(from-bowHeight)) boxLeft (bottom+fontHeight*(from+gradientHeight)) (colorFromPitch pitch) PDF.black) $ tube (boxLeft+fontHeight*0.1) (bottom+fontHeight*from) (boxLeft+fontHeight*0.9) (bottom+to) Fold.for_ (zip [0..] noteNames) $ \(pitch,char) -> do PDF.fillColor $ colorFromPitch pitch let boxLeft = boxLeftFromPitch pitch let bowHalf = bowHeight/2 tube (boxLeft+fontHeight*0.1) (bottom+fontHeight*(bowHalf-0.1)) (boxLeft+fontHeight*0.9) (bottom+fontHeight*(bowHalf+0.9)) PDF.fillPath PDF.fillColor PDF.white PDF.setWidth 0.5 PDF.strokeColor (grey 0.1) PDF.drawText $ do let font = PDF.PDFFont stdFont fontHeight_ PDF.setFont font let label = fromString [char] let leftOffset = (fontHeight - PDF.textWidth font label) / 2 PDF.textStart (boxLeft + leftOffset) bottom PDF.renderMode PDF.FillAndStrokeText PDF.displayText label animate :: Double -> Integer -> VoiceMsg.Pitch -> FilePath -> FilePath -> IO () animate timeStep frameRate zeroKey input output = do midi <- MidiLoad.fromFile input let track = mergeTracksToAbsolute midi let duration = maybe 0 (fst.snd) $ AbsEventList.viewR track let bottom = 0.5 let height = 9 let start = windowInitialize height $ layoutTubes timeStep zeroKey track let ts = map (/timeStep) [0, recip (fromInteger frameRate) .. duration] let frames = scanl (\display times -> windowMove times display) start $ map (\t -> (t-bottom, t+height)) ts writePDF output PDF.Helvetica_Bold 16 $ zipWith (\t -> map (mapTriple (subtract t, fmap (subtract t), id)) . windowLayout . fst) ts frames info :: OP.Parser a -> OP.ParserInfo a info p = OP.info (OP.helper <*> p) (OP.fullDesc <> OP.progDesc "Generate boomwhacker animation from MIDI file.") parser :: OP.Parser (IO ()) parser = pure animate <*> OP.option OP.auto (OP.long "timestep" <> OP.metavar "SECONDS" <> OP.value 0.2 <> OP.help "time step between lines") <*> OP.option OP.auto (OP.long "rate" <> OP.metavar "FPS" <> OP.value 25 <> OP.help "frame rate") <*> (VoiceMsg.toPitch <$> OP.option OP.auto (OP.long "zerokey" <> OP.metavar "INT" <> OP.value 60 <> OP.help "MIDI key for the left-most tube")) <*> OP.strArgument (OP.metavar "INPUT" <> OP.help "Input MIDI file") <*> OP.strArgument (OP.metavar "OUTPUT" <> OP.help "Output PDF file") main :: IO () main = join $ OP.execParser $ info parser