module Main where import qualified Options.Applicative as OP import qualified Graphics.PDF as PDF import Shell.Utility.ParseArgument (parseNumber) 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.IntSet as IntSet import qualified Data.Foldable as Fold import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.NonEmpty as NonEmpty import qualified Data.Empty as Empty import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) import Data.Array (Array, listArray, (!)) import Data.Tuple.HT (mapTriple, thd3) import Data.NonEmpty ((!:)) import Data.String (fromString) import Data.Complex (Complex((:+))) import Control.Monad (join, when) 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) minimalDistanceToTubeHeads :: [(Double, Maybe Double, Int)] -> IntMap Double minimalDistanceToTubeHeads = IntMap.fromListWith min . map (\(from, _mTo, pitch) -> (pitch, abs from)) 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 noteLetters :: [Char] noteLetters = ['C', '#', 'D', '#', 'E', 'F', '#', 'G', '#', 'A', '#', 'B', 'C'] noteNameList :: [String] noteNameList = ["C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B=H", "C"] noteNames :: Array Int String noteNames = listArray (0, length noteNameList - 1) noteNameList type List3 = NonEmpty.T (NonEmpty.T (NonEmpty.T Empty.T)) type RGB = List3 Double noteColors :: Array Int RGB 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) -> 0.01*r !: 0.01*g !: 0.01*b !: Empty.Cons) xs uncurry3 :: (a -> a -> a -> b) -> NonEmpty.T (NonEmpty.T (NonEmpty.T Empty.T)) a -> b uncurry3 f (NonEmpty.Cons x0 (NonEmpty.Cons x1 (NonEmpty.Cons x2 Empty.Cons))) = f x0 x1 x2 grey :: Double -> PDF.Color grey brightness = PDF.Rgb brightness brightness brightness colorFromPitch :: (Int,Int) -> Double -> Int -> RGB colorFromPitch pitchRange brightness pitch = if Array.inRange pitchRange pitch then fmap (brightness*) $ noteColors ! mod pitch (snd $ Array.bounds noteColors) else NonEmptyC.repeat $ brightness*0.5 interpolateColor :: Double -> RGB -> RGB -> RGB interpolateColor k = NonEmptyC.zipWith (\x y -> (1-k)*x + k*y) writePDF :: FilePath -> Int -> PDF.FontName -> Int -> IntSet -> [[(Double, Maybe Double, Int)]] -> IO () writePDF path heightPoints fontName fontHeight_ usedCups blocks = do let fontHeight = fromIntegral fontHeight_ lowestPitch = maybe 0 (min 0 . fst) $ IntSet.minView usedCups highestPitch = maybe 12 (max 12 . fst) $ IntSet.maxView usedCups pitchRange = (lowestPitch, highestPitch) width = fromIntegral (highestPitch-lowestPitch+1) * fontHeight height = fromIntegral heightPoints bottom = 0.5 * fontHeight flashVelocity = 1.5 gradientHeight = height boxLeftFromPitch pitch = fromIntegral (pitch - lowestPitch) * 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) (uncurry3 PDF.Rgb $ colorFromPitch pitchRange 1 pitch) PDF.black) $ tube (boxLeft+fontHeight*0.1) (bottom+fontHeight*from) (boxLeft+fontHeight*0.9) (bottom+to) let headDistances = minimalDistanceToTubeHeads block Fold.for_ (Array.range pitchRange) $ \pitch -> do let (brightness, flashShift) = if IntSet.member pitch usedCups then (1.0, maybe 1 (\dist -> min 1 $ flashVelocity*dist) $ IntMap.lookup pitch headDistances) else (0.2, 1) PDF.fillColor $ uncurry3 PDF.Rgb $ interpolateColor flashShift (NonEmptyC.repeat 1) $ colorFromPitch pitchRange brightness 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 $ grey $ brightness*flashShift PDF.setWidth 0.5 PDF.strokeColor PDF.black do let label = noteNames ! mod pitch (snd $ Array.bounds noteNames) let (upper, lower) = case break ('='==) label of (xs, "") -> ("", xs) (xs, ys) -> (xs, ys) let textColumns = max (length upper) (length lower) let font = PDF.PDFFont stdFont (div fontHeight_ textColumns) let upperText = fromString upper let lowerText = fromString lower let textWidth = max (PDF.textWidth font upperText) (PDF.textWidth font lowerText) let textLeft = boxLeft + (fontHeight - textWidth) / 2 when (not $ null upper) $ PDF.drawText $ do PDF.setFont font PDF.renderMode PDF.FillAndStrokeText PDF.textStart textLeft (bottom + fontHeight * 0.4) PDF.displayText upperText PDF.drawText $ do PDF.setFont font PDF.renderMode PDF.FillAndStrokeText PDF.textStart textLeft bottom PDF.displayText lowerText animate :: Double -> Integer -> VoiceMsg.Pitch -> Int -> Int -> FilePath -> FilePath -> IO () animate timeStep frameRate zeroKey heightPoints fontHeight 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 = fromIntegral heightPoints / fromIntegral fontHeight let tubes = layoutTubes timeStep zeroKey track let usedCups = IntSet.fromList $ map (fst.snd) tubes let start = windowInitialize height tubes 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 heightPoints PDF.Helvetica_Bold fontHeight usedCups $ 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.option (OP.eitherReader $ parseNumber "height" (0<) "positive") $ OP.long "height" <> OP.metavar "POINTS" <> OP.value 720 <> OP.help "Height of the paper in typographical points") <*> (OP.option (OP.eitherReader $ parseNumber "font height" (0<) "positive") $ OP.long "font-height" <> OP.metavar "POINTS" <> OP.value 80 <> OP.help "Font height") <*> 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