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